From dd09f3b6e843db17b3ceb33d1bce3e57f0352220 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Mon, 23 Dec 2024 12:19:46 -0500 Subject: [PATCH 01/30] Reset domain lock in caml_thread_reinitialize (#3379) reset domain lock in systhreads fork --- otherlibs/systhreads/st_stubs.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index 84db67b7548..a01d80755ab 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -572,10 +572,9 @@ static void caml_thread_reinitialize(void) Active_thread->next = Active_thread; Active_thread->prev = Active_thread; - // CR ocaml 5 domains: systhreads doesn't maintain domain lock /* Within the child, the domain_lock needs to be reset and acquired. */ - // caml_reset_domain_lock(); - // caml_acquire_domain_lock(); + caml_reset_domain_lock(); + caml_acquire_domain_lock(); /* The lock needs to be initialized again. This process will also be the effective owner of the lock. So there is no need to run From 6da1dde0b8a3391d08d5267c2c58654694bda880 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 23 Dec 2024 17:34:55 +0000 Subject: [PATCH 02/30] Implement %makearray_dynamic{,_uninit} (#3317) Co-authored-by: Chris Casinghino Co-authored-by: Ryan Tjoa --- .github/workflows/build.yml | 4 +- bytecomp/bytegen.ml | 60 +- lambda/lambda.ml | 71 +- lambda/lambda.mli | 27 +- lambda/printlambda.ml | 12 +- lambda/printlambda.mli | 1 + lambda/translprim.ml | 91 +- lambda/translprim.mli | 1 + .../from_lambda/closure_conversion.ml | 21 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 5 +- .../lambda_to_flambda_primitives.ml | 162 +- .../lambda_to_flambda_primitives.mli | 2 + .../lambda_to_lambda_transforms.ml | 451 +- .../lambda_to_lambda_transforms.mli | 3 +- runtime/array.c | 224 +- runtime/caml/custom.h | 7 + runtime/caml/memory.h | 1 + runtime/custom.c | 39 +- runtime/float32.c | 21 +- runtime/memory.c | 14 +- runtime/simd.c | 39 +- runtime4/array.c | 228 +- runtime4/caml/custom.h | 7 + runtime4/caml/memory.h | 1 + runtime4/custom.c | 27 +- runtime4/float32.c | 21 +- runtime4/memory.c | 14 +- runtime4/simd.c | 39 +- .../tests/typing-layouts-arrays/README.md | 34 + .../typing-layouts-arrays/basics_alpha.ml | 299 + .../gen_product_array_helpers.ml | 353 + .../gen_product_array_helpers.mli | 26 + .../generate_makearray_dynamic_tests.ml | 682 ++ .../typing-layouts-arrays/generated_test.ml | 8785 +++++++++++++++++ .../generated_test.reference | 5 + .../run_makearray_dynamic_tests.ml | 24 + .../test_float_u_array.ml | 93 + .../test_ignorable_product_array_1.ml | 93 + .../test_ignorable_product_array_2.ml | 114 + ...t_ignorable_product_array_with_uninit_1.ml | 90 + ...t_ignorable_product_array_with_uninit_2.ml | 111 + .../test_scannable_product_array_1.ml | 94 + .../test_scannable_product_array_2.ml | 116 + .../test_scannable_product_array_3.ml | 96 + .../test_scannable_product_array_4.ml | 100 + .../tests/typing-layouts-products/basics.ml | 27 +- .../typing-layouts-products/product_arrays.ml | 10 +- .../product_iarrays.ml | 2 +- .../basics_from_unboxed_tuples_tests.ml | 8 +- testsuite/tests/typing-layouts/layout_poly.ml | 21 +- typing/primitive.ml | 6 + typing/typeopt.ml | 2 +- 52 files changed, 12558 insertions(+), 226 deletions(-) create mode 100644 testsuite/tests/typing-layouts-arrays/README.md create mode 100644 testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml create mode 100644 testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli create mode 100644 testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml create mode 100644 testsuite/tests/typing-layouts-arrays/generated_test.ml create mode 100644 testsuite/tests/typing-layouts-arrays/generated_test.reference create mode 100644 testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_float_u_array.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml create mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 19b8646c36b..642675b0048 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -109,8 +109,8 @@ jobs: - name: gi config: --enable-middle-end=flambda2 os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1,vectorize=1' - ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1,vectorize=1' + build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1' + ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1' check_arch: true - name: cfg-selection diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 95e5137d184..73b0160071f 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -685,7 +685,10 @@ let comp_primitive stack_info p sz args = "Preinterpret_unboxed_int64_as_tagged_int63 can only be used on 64-bit \ targets"; Kccall("caml_reinterpret_unboxed_int64_as_tagged_int63", 1) - | Pmakearray_dynamic(kind, locality) -> + | Pmakearray_dynamic(kind, locality, With_initializer) -> + if List.compare_length_with args 2 <> 0 then + fatal_error "Bytegen.comp_primitive: Pmakearray_dynamic takes two \ + arguments for [With_initializer]"; (* CR layouts v4.0: This is "wrong" for unboxed types. It should construct blocks that can't be marshalled. We've decided to ignore that problem in the short term, as it's unlikely to cause issues - see the internal arrays @@ -701,8 +704,8 @@ let comp_primitive stack_info p sz args = | Alloc_heap -> Kccall("caml_make_vect", 2) | Alloc_local -> Kccall("caml_make_local_vect", 2) end - | Parrayblit(kind) -> - begin match kind with + | Parrayblit { src_mutability = _; dst_array_set_kind } -> + begin match dst_array_set_kind with | Punboxedvectorarray_set _ -> fatal_error "SIMD is not supported in bytecode mode." | Pgenarray_set _ | Pintarray_set | Paddrarray_set _ @@ -710,6 +713,9 @@ let comp_primitive stack_info p sz args = | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _ -> () end; Kccall("caml_array_blit", 5) + | Pmakearray_dynamic(_, _, Uninitialized) -> + Misc.fatal_error "Pmakearray_dynamic Uninitialized should have been \ + translated to Pmakearray_dynamic Initialized earlier on" (* The cases below are handled in [comp_expr] before the [comp_primitive] call (in the order in which they appear below), so they should never be reached in this function. *) @@ -986,6 +992,54 @@ let rec comp_expr stack_info env exp sz cont = (Kreperformterm(sz + nargs) :: discard_dead_code cont) else fatal_error "Reperform used in non-tail position" + | Lprim (Pmakearray_dynamic (kind, locality, Uninitialized), [len], loc) -> + (* Use a dummy initializer to implement the "uninitialized" primitive *) + let init = + match kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray + | Pgcscannableproductarray _ -> + Misc.fatal_errorf "Array kind %s should have been ruled out by \ + the frontend for %%makearray_dynamic_uninit" + (Printlambda.array_kind kind) + | Punboxedfloatarray Unboxed_float32 -> + Lconst (Const_base (Const_float32 "0.0")) + | Punboxedfloatarray Unboxed_float64 -> + Lconst (Const_base (Const_float "0.0")) + | Punboxedintarray Unboxed_int32 -> + Lconst (Const_base (Const_int32 0l)) + | Punboxedintarray Unboxed_int64 -> + Lconst (Const_base (Const_int64 0L)) + | Punboxedintarray Unboxed_nativeint -> + Lconst (Const_base (Const_nativeint 0n)) + | Punboxedvectorarray _ -> + fatal_error "SIMD is not supported in bytecode mode." + | Pgcignorableproductarray ignorables -> + let rec convert_ignorable + (ign : Lambda.ignorable_product_element_kind) = + match ign with + | Pint_ignorable -> Lconst (Const_base (Const_int 0)) + | Punboxedfloat_ignorable Unboxed_float32 -> + Lconst (Const_base (Const_float32 "0.0")) + | Punboxedfloat_ignorable Unboxed_float64 -> + Lconst (Const_base (Const_float "0.0")) + | Punboxedint_ignorable Unboxed_int32 -> + Lconst (Const_base (Const_int32 0l)) + | Punboxedint_ignorable Unboxed_int64 -> + Lconst (Const_base (Const_int64 0L)) + | Punboxedint_ignorable Unboxed_nativeint -> + Lconst (Const_base (Const_nativeint 0n)) + | Pproduct_ignorable ignorables -> + let fields = List.map convert_ignorable ignorables in + Lprim (Pmakeblock (0, Immutable, None, alloc_heap), fields, + loc) + in + convert_ignorable (Pproduct_ignorable ignorables) + in + comp_expr stack_info env + (Lprim (Pmakearray_dynamic (kind, locality, With_initializer), + [len; init], loc)) sz cont + | Lprim (Pmakearray_dynamic (_, _, Uninitialized), _, _loc) -> + Misc.fatal_error "Pmakearray_dynamic takes one arg when [Uninitialized]" | Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind',_,m),args,_)], loc) -> assert (kind = kind'); diff --git a/lambda/lambda.ml b/lambda/lambda.ml index a151ee51b1d..d5bc289e09a 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -43,6 +43,10 @@ type field_read_semantics = | Reads_agree | Reads_vary +type has_initializer = + | With_initializer + | Uninitialized + include (struct type locality_mode = @@ -189,9 +193,12 @@ type primitive = | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag * locality_mode - | Pmakearray_dynamic of array_kind * locality_mode + | Pmakearray_dynamic of array_kind * locality_mode * has_initializer | Pduparray of array_kind * mutable_flag - | Parrayblit of array_set_kind (* Kind of the dest array. *) + | Parrayblit of { + src_mutability : mutable_flag; + dst_array_set_kind : array_set_kind; + } | Parraylength of array_kind | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag | Parraysetu of array_set_kind * array_index_kind @@ -944,6 +951,10 @@ let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region = let lambda_unit = Lconst const_unit +let of_bool = function + | true -> Lconst (const_int 1) + | false -> Lconst (const_int 0) + (* CR vlaviron: review the following cases *) let non_null_value raw_kind = Pvalue { raw_kind; nullable = Non_nullable } @@ -1819,7 +1830,7 @@ let primitive_may_allocate : primitive -> locality_mode option = function | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None | Pmakearray (_, _, m) -> Some m - | Pmakearray_dynamic (_, m) -> Some m + | Pmakearray_dynamic (_, m, _) -> Some m | Pduparray _ -> Some alloc_heap | Parraylength _ -> None | Parrayblit _ @@ -2388,6 +2399,21 @@ let array_set_kind mode = function | Pgcscannableproductarray kinds -> Pgcscannableproductarray_set (mode, kinds) | Pgcignorableproductarray kinds -> Pgcignorableproductarray_set kinds +let array_ref_kind_of_array_set_kind (kind : array_set_kind) mode + : array_ref_kind = + match kind with + | Pintarray_set -> Pintarray_ref + | Punboxedfloatarray_set uf -> Punboxedfloatarray_ref uf + | Punboxedintarray_set ui -> Punboxedintarray_ref ui + | Punboxedvectorarray_set uv -> Punboxedvectorarray_ref uv + | Pgcscannableproductarray_set (_, scannables) -> + Pgcscannableproductarray_ref scannables + | Pgcignorableproductarray_set ignorables -> + Pgcignorableproductarray_ref ignorables + | Pgenarray_set _ -> Pgenarray_ref mode + | Paddrarray_set _ -> Paddrarray_ref + | Pfloatarray_set -> Pfloatarray_ref mode + let may_allocate_in_region lam = (* loop_region raises, if the lambda might allocate in parent region *) let rec loop_region lam = @@ -2479,3 +2505,42 @@ let rec try_to_find_location lam = let try_to_find_debuginfo lam = Debuginfo.from_location (try_to_find_location lam) + +let rec count_initializers_scannable + (scannable : scannable_product_element_kind) = + match scannable with + | Pint_scannable | Paddr_scannable -> 1 + | Pproduct_scannable scannables -> + List.fold_left + (fun acc scannable -> acc + count_initializers_scannable scannable) + 0 scannables + +let rec count_initializers_ignorable + (ignorable : ignorable_product_element_kind) = + match ignorable with + | Pint_ignorable | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> 1 + | Pproduct_ignorable ignorables -> + List.fold_left + (fun acc ignorable -> acc + count_initializers_ignorable ignorable) + 0 ignorables + +let count_initializers_array_kind (lambda_array_kind : array_kind) = + match lambda_array_kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray _ + | Punboxedintarray _ | Punboxedvectorarray _ -> 1 + | Pgcscannableproductarray scannables -> + List.fold_left + (fun acc scannable -> acc + count_initializers_scannable scannable) + 0 scannables + | Pgcignorableproductarray ignorables -> + List.fold_left + (fun acc ignorable -> acc + count_initializers_ignorable ignorable) + 0 ignorables + +let rec ignorable_product_element_kind_involves_int + (kind : ignorable_product_element_kind) = + match kind with + | Pint_ignorable -> true + | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> false + | Pproduct_ignorable kinds -> + List.exists ignorable_product_element_kind_involves_int kinds diff --git a/lambda/lambda.mli b/lambda/lambda.mli index f72780dda1c..31a90c4434e 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -74,6 +74,10 @@ type field_read_semantics = | Reads_agree | Reads_vary +type has_initializer = + | With_initializer + | Uninitialized + (* Tail calls can close their enclosing region early *) type region_close = | Rc_normal (* do not close region, may TCO if in tail position *) @@ -178,15 +182,21 @@ type primitive = | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag * locality_mode - | Pmakearray_dynamic of array_kind * locality_mode + | Pmakearray_dynamic of array_kind * locality_mode * has_initializer + (** For [Pmakearray_dynamic], if the array kind specifies an unboxed + product, the float array optimization will never apply. *) | Pduparray of array_kind * mutable_flag (** For [Pduparray], the argument must be an immutable array. The arguments of [Pduparray] give the kind and mutability of the array being *produced* by the duplication. *) - | Parrayblit of array_set_kind + | Parrayblit of { + src_mutability : mutable_flag; + dst_array_set_kind : array_set_kind; + } (** For [Parrayblit], we record the [array_set_kind] of the destination array. We check that the source array has the same shape, but do not - need to know anything about its locality. *) + need to know anything about its locality. We do however request the + mutability of the source array. *) | Parraylength of array_kind | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag | Parraysetu of array_set_kind * array_index_kind @@ -914,6 +924,8 @@ val const_unit: structured_constant val const_int : int -> structured_constant val lambda_unit: lambda +val of_bool : bool -> lambda + val layout_unit : layout val layout_int : layout val layout_array : array_kind -> layout @@ -1158,6 +1170,11 @@ val array_ref_kind : locality_mode -> array_kind -> array_ref_kind (** The mode will be discarded if unnecessary for the given [array_kind] *) val array_set_kind : modify_mode -> array_kind -> array_set_kind +(** Any mode information in the given [array_set_kind] is ignored. Any mode + in the return value always comes from the [locality_mode] parameter. *) +val array_ref_kind_of_array_set_kind + : array_set_kind -> locality_mode -> array_ref_kind + (* Returns true if the given lambda can allocate on the local stack *) val may_allocate_in_region : lambda -> bool @@ -1173,3 +1190,7 @@ val try_to_find_location : lambda -> scoped_location val try_to_find_debuginfo : lambda -> Debuginfo.t val primitive_can_raise : primitive -> bool + +val count_initializers_array_kind : array_kind -> int +val ignorable_product_element_kind_involves_int : + ignorable_product_element_kind -> bool diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index ed0e1326695..74cd27a3e1b 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -668,14 +668,20 @@ let primitive ppf = function | Pmakearray (k, Immutable_unique, mode) -> fprintf ppf "make%sarray_unique[%s]" (locality_mode_if_local mode) (array_kind k) - | Pmakearray_dynamic (k, mode) -> - fprintf ppf "make%sarray_any[%s]" (locality_mode_if_local mode) + | Pmakearray_dynamic (k, mode, has_init) -> + fprintf ppf "make%sarray_any[%s]%s" (locality_mode_if_local mode) (array_kind k) + (match has_init with + | With_initializer -> "" + | Uninitialized -> "[uninit]") | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) | Pduparray (k, Immutable_unique) -> fprintf ppf "duparray_unique[%s]" (array_kind k) - | Parrayblit sk -> fprintf ppf "arrayblit[%a]" array_set_kind sk + | Parrayblit { src_mutability; dst_array_set_kind } -> + fprintf ppf "arrayblit[%s -> %a]" + (array_mut src_mutability) + array_set_kind dst_array_set_kind | Parrayrefu (rk, idx, mut) -> fprintf ppf "%s.unsafe_get[%a indexed by %a]" (array_mut mut) array_ref_kind rk diff --git a/lambda/printlambda.mli b/lambda/printlambda.mli index fc4b898a224..05bb1f49f1d 100644 --- a/lambda/printlambda.mli +++ b/lambda/printlambda.mli @@ -44,6 +44,7 @@ val print_bigarray : val zero_alloc_attribute : formatter -> zero_alloc_attribute -> unit val locality_mode : formatter -> locality_mode -> unit val array_kind : array_kind -> string +val array_set_kind : formatter -> array_set_kind -> unit val tag_and_constructor_shape : (formatter -> value_kind -> unit) -> diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 109651c043c..770a4f8ecc1 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -30,6 +30,7 @@ type error = | Wrong_arity_builtin_primitive of string | Invalid_floatarray_glb | Product_iarrays_unsupported + | Invalid_array_kind_for_uninitialized_makearray_dynamic exception Error of Location.t * error @@ -45,6 +46,18 @@ let unboxed_product_iarray_check loc kind mut = | Punboxedintarray _ | Punboxedvectorarray _), _ -> () +let unboxed_product_uninitialized_array_check loc array_kind = + (* See comments in lambda_to_lambda_transforms.ml in Flambda 2 for more + details on this restriction. *) + match array_kind with + | Pgcignorableproductarray igns + when not (List.exists + Lambda.ignorable_product_element_kind_involves_int igns) -> () + | Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _ -> + () + | Pgenarray | Paddrarray | Pintarray | Pfloatarray + | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> + raise (Error (loc, Invalid_array_kind_for_uninitialized_makearray_dynamic)) (* Insertion of debugging events *) @@ -531,11 +544,23 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_nativeint)), 3) | "%makearray_dynamic" -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Alpha; - Primitive (Pmakearray_dynamic (gen_array_kind, mode), 2) + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Pmakearray_dynamic (gen_array_kind, mode, With_initializer), 2) + | "%makearray_dynamic_uninit" -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Pmakearray_dynamic (gen_array_kind, mode, Uninitialized), 1) | "%arrayblit" -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Alpha; - Primitive (Parrayblit (gen_array_set_kind (get_third_arg_mode ())), 5) + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Parrayblit { + src_mutability = Mutable; + dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ()) + }, 5); + | "%arrayblit_src_immut" -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Parrayblit { + src_mutability = Immutable; + dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ()) + }, 5); | "%obj_size" -> Primitive ((Parraylength Pgenarray), 1) | "%obj_field" -> Primitive ((Parrayrefu (Pgenarray_ref mode, Ptagged_int_index, Mutable)), 2) | "%obj_set_field" -> @@ -1229,19 +1254,40 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = if st = array_set_type then None else Some (Primitive (Parraysets (array_set_type, index_kind), arity)) end - | Primitive (Pmakearray_dynamic (at, mode), arity), - _ :: p2 :: _ -> begin + | Primitive (Pmakearray_dynamic (array_kind, mode, With_initializer), 2), + _ :: p2 :: [] -> begin let loc = to_location loc in - let array_type = - glb_array_type loc at - (array_kind_of_elt ~elt_sort:None env loc p2) + let new_array_kind = + array_kind_of_elt ~elt_sort:None env loc p2 + |> glb_array_type loc array_kind in let array_mut = array_type_mut env rest_ty in - unboxed_product_iarray_check loc array_type array_mut; - if at = array_type then None - else Some (Primitive (Pmakearray_dynamic (array_type, mode), arity)) + unboxed_product_iarray_check loc new_array_kind array_mut; + if array_kind = new_array_kind then None + else + Some (Primitive (Pmakearray_dynamic ( + new_array_kind, mode, With_initializer), 2)) end - | Primitive (Parrayblit st, arity), + | Primitive (Pmakearray_dynamic (array_kind, mode, Uninitialized), 1), + _ :: [] -> begin + let loc = to_location loc in + let new_array_kind = + array_type_kind ~elt_sort:None env loc rest_ty + |> glb_array_type loc array_kind + in + let array_mut = array_type_mut env rest_ty in + unboxed_product_iarray_check loc new_array_kind array_mut; + unboxed_product_uninitialized_array_check loc new_array_kind; + if array_kind = new_array_kind then None + else + Some (Primitive (Pmakearray_dynamic ( + new_array_kind, mode, Uninitialized), 1)) + end + | Primitive (Pmakearray_dynamic _, arity), args -> + Misc.fatal_errorf + "Wrong arity for Pmakearray_dynamic (arity=%d, args length %d)" + arity (List.length args) + | Primitive (Parrayblit { src_mutability; dst_array_set_kind }, arity), _p1 :: _ :: p2 :: _ -> let loc = to_location loc in (* We only use the kind of one of two input arrays here. If you've bound the @@ -1249,11 +1295,13 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = kind. If you haven't, then taking the glb of both would be just as likely to compound your error (e.g., by treating a Pgenarray as a Pfloatarray) as to help you. *) - let array_type = - glb_array_set_type loc st (array_type_kind ~elt_sort:None env loc p2) + let array_kind = array_type_kind ~elt_sort:None env loc p2 in + let new_dst_array_set_kind = + glb_array_set_type loc dst_array_set_kind array_kind in - if st = array_type then None - else Some (Primitive (Parrayblit array_type, arity)) + if dst_array_set_kind = new_dst_array_set_kind then None + else Some (Primitive (Parrayblit { + src_mutability; dst_array_set_kind = new_dst_array_set_kind }, arity)) | Primitive (Pbigarrayref(unsafe, n, kind, layout), arity), p1 :: _ -> begin let (k, l) = bigarray_specialize_kind_and_layout env ~kind ~layout p1 in match k, l with @@ -1733,7 +1781,7 @@ let lambda_primitive_needs_event_after = function | Pmulfloat (_, _) | Pdivfloat (_, _) | Pstringrefs | Pbytesrefs | Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _ - | Pmakearray_dynamic (Pgenarray, _) + | Pmakearray_dynamic (Pgenarray, _, _) | Parrayrefu ((Pgenarray_ref _ | Pfloatarray_ref _), _, _) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ @@ -1783,7 +1831,7 @@ let lambda_primitive_needs_event_after = function | Pmakearray_dynamic ((Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _ - | Pgcscannableproductarray _ | Pgcignorableproductarray _), _) + | Pgcscannableproductarray _ | Pgcignorableproductarray _), _, _) | Parrayblit _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisnull | Pisout | Pprobe_is_enabled _ @@ -1857,6 +1905,11 @@ let report_error ppf = function | Product_iarrays_unsupported -> fprintf ppf "Immutable arrays of unboxed products are not yet supported." + | Invalid_array_kind_for_uninitialized_makearray_dynamic -> + fprintf ppf + "%%makearray_dynamic_uninit can only be used for GC-ignorable arrays@ \ + not involving tagged immediates; and arrays of unboxed numbers.@ Use \ + %%makearray instead, providing an initializer." let () = Location.register_error_of_exn diff --git a/lambda/translprim.mli b/lambda/translprim.mli index 10916122801..2f58c381370 100644 --- a/lambda/translprim.mli +++ b/lambda/translprim.mli @@ -64,6 +64,7 @@ type error = | Wrong_arity_builtin_primitive of string | Invalid_floatarray_glb | Product_iarrays_unsupported + | Invalid_array_kind_for_uninitialized_makearray_dynamic exception Error of Location.t * error diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 00f1f447c81..eac97e6e665 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -993,19 +993,18 @@ let close_primitive acc env ~let_bound_ids_with_kinds named | Pmakearray (array_kind, _, _mode) -> let array_kind = Empty_array_kind.of_lambda array_kind in register_const0 acc (Static_const.empty_array array_kind) "empty_array" - | Pmakearray_dynamic (_array_kind, _mode) -> - Misc.fatal_error "Closure_conversion.close_primitive: unimplemented" | Parrayblit _array_set_kind -> Misc.fatal_error "Closure_conversion.close_primitive: unimplemented" - | Pbytes_to_string | Pbytes_of_string | Parray_of_iarray - | Parray_to_iarray | Pignore | Pgetglobal _ | Psetglobal _ | Pgetpredef _ - | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ - | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ - | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor | Pnot | Pnegint - | Pmixedfield _ | Psetmixedfield _ | Paddint | Psubint | Pmulint - | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint - | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats _ - | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat _ + | Pmakearray_dynamic _ | Pbytes_to_string | Pbytes_of_string + | Parray_of_iarray | Parray_to_iarray | Pignore | Pgetglobal _ + | Psetglobal _ | Pgetpredef _ | Pfield _ | Pfield_computed _ | Psetfield _ + | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ + | Pccall _ | Praise _ | Pufloatfield _ | Psetufloatfield _ | Psequand + | Psequor | Pnot | Pnegint | Pmixedfield _ | Psetmixedfield _ | Paddint + | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints + | Pcompare_floats _ | Pcompare_bints _ | Poffsetint _ | Poffsetref _ + | Pintoffloat _ | Pfloatofint (_, _) | Pfloatoffloat32 _ | Pfloat32offloat _ | Pnegfloat (_, _) diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 3f232bb6643..80c5b51a1cd 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -535,7 +535,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) id, Lprim (prim, args, loc), body ) -> ( - match Lambda_to_lambda_transforms.transform_primitive env prim args loc with + let env, result = + Lambda_to_lambda_transforms.transform_primitive env prim args loc + in + match result with | Primitive (prim, args, loc) -> (* This case avoids extraneous continuations. *) let exn_continuation : IR.exn_continuation option = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index c91ccd3663b..3cc3cf9d30a 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -814,13 +814,48 @@ let bytes_like_set ~dbg ~unsafe (* Array bounds checks *) +(* The following function constructs bounds checks based on two things: + + 1. The array length kind, which specifies the representation of the array, + including any unboxed product types. This kind is used to establish the + starting field index in the runtime value where the access(es) is/are going + to occur, in addition to how many fields are going to be accessed at a + minimum. "How many fields" is always one except in the case where unboxed + products are involved: in such cases, more than one field may be accessed. + "At a minimum" only applies for vector reinterpret operations as described + next; in all other cases this number is exact. + + 2. The [num_consecutive_elements_being_accessed]. "Elements" here refers to + the non-unarized elements as the user sees via the array get/set primitives. + This value is always 1 except in the case where the array operation is in + fact really a reinterpret operation with a vector input or output (for + example an array of naked floats being read as a 128-bit vector of such + floats). In these latter cases the value of + [num_consecutive_elements_being_accessed] may be greater than 1. This value + may not be greater than 1 if unboxed products are involved, at present. *) + +(* CR mshinwell: When considering vectors and unboxed products, we should think + again about whether the abstractions/concepts here can be improved. *) let multiple_word_array_access_validity_condition array ~size_int - array_length_kind (index_kind : L.array_index_kind) ~width_in_scalars ~index - = + array_length_kind (index_kind : L.array_index_kind) + ~num_consecutive_elements_being_accessed ~index = + let width_in_scalars_per_access = + P.Array_kind_for_length.width_in_scalars array_length_kind + in + assert (width_in_scalars_per_access >= 1); let length_tagged = H.Prim (Unary (Array_length array_length_kind, array)) in - if width_in_scalars < 1 - then Misc.fatal_errorf "Invalid width_in_scalars value: %d" width_in_scalars - else if width_in_scalars = 1 + if num_consecutive_elements_being_accessed < 1 + then + Misc.fatal_errorf + "Invalid num_consecutive_elements_being_accessed value: %d" + num_consecutive_elements_being_accessed + else if width_in_scalars_per_access > 1 + && num_consecutive_elements_being_accessed > 1 + then + Misc.fatal_error + "Unboxed product arrays cannot involve vector accesses at present" + else if width_in_scalars_per_access = 1 + && num_consecutive_elements_being_accessed = 1 then (* Ensure good code generation in the common case. *) check_bound ~index_kind ~bound_kind:Tagged_immediate ~index @@ -828,13 +863,19 @@ let multiple_word_array_access_validity_condition array ~size_int else let length_untagged = untag_int length_tagged in let reduced_length_untagged = - H.Prim - (Binary - ( Int_arith (Naked_immediate, Sub), - length_untagged, - Simple - (Simple.untagged_const_int - (Targetint_31_63.of_int (width_in_scalars - 1))) )) + if num_consecutive_elements_being_accessed = 1 + then length_untagged + else + (* This is used for vector accesses, where no unarization is + involved. *) + H.Prim + (Binary + ( Int_arith (Naked_immediate, Sub), + length_untagged, + Simple + (Simple.untagged_const_int + (Targetint_31_63.of_int + (num_consecutive_elements_being_accessed - 1))) )) in (* We need to convert the length into a naked_nativeint because the optimised version of the max_with_zero function needs to be on @@ -847,34 +888,21 @@ let multiple_word_array_access_validity_condition array ~size_int reduced_length_untagged )) in let nativeint_bound = max_with_zero ~size_int reduced_length_nativeint in - let index : H.simple_or_prim = - (* [length_tagged] is in units of scalars. Multiply up [index] to - match. *) - let multiplier = - P.Array_kind_for_length.width_in_scalars array_length_kind - in - let arith_kind, multiplier = - match index_kind with - | Ptagged_int_index -> - ( I.Tagged_immediate, - Simple.const_int (Targetint_31_63.of_int multiplier) ) - | Punboxed_int_index bint -> ( - match bint with - | Unboxed_int32 -> - ( I.Naked_int32, - Simple.const - (Reg_width_const.naked_int32 (Int32.of_int multiplier)) ) - | Unboxed_int64 -> - ( I.Naked_int64, - Simple.const - (Reg_width_const.naked_int64 (Int64.of_int multiplier)) ) - | Unboxed_nativeint -> - ( I.Naked_nativeint, - Simple.const - (Reg_width_const.naked_nativeint - (Targetint_32_64.of_int multiplier)) )) - in - Prim (Binary (Int_arith (arith_kind, Mul), index, Simple multiplier)) + let nativeint_bound : H.simple_or_prim = + if width_in_scalars_per_access = 1 + then nativeint_bound + else + (* This is used for unboxed product accesses. [index] is in non-unarized + terms and we don't touch it, to avoid risks of overflow. Instead we + compute the non-unarized bound, then compare against that. *) + Prim + (Binary + ( Int_arith (Naked_nativeint, Div), + nativeint_bound, + Simple + (Simple.const + (Reg_width_const.naked_nativeint + (Targetint_32_64.of_int width_in_scalars_per_access))) )) in check_bound ~index_kind ~bound_kind:Naked_nativeint ~index ~bound:nativeint_bound @@ -883,25 +911,25 @@ let multiple_word_array_access_validity_condition array ~size_int (* CR mshinwell: it seems like these could be folded into the normal array load/store functions below *) -let array_vector_access_width_in_scalars (array_kind : P.Array_kind.t) = - match array_kind with - | Naked_vec128s -> 1 - | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2 - | Naked_int32s | Naked_float32s -> 4 - | Values -> - Misc.fatal_error - "Attempted to load/store a SIMD vector from/to a value array." - | Unboxed_product _ -> - (* CR mshinwell: support unboxed products involving vectors? *) - Misc.fatal_error - "Attempted to load/store a SIMD vector from/to an unboxed product array, \ - which is not yet supported." - let array_vector_access_validity_condition array ~size_int (array_kind : P.Array_kind.t) index = - let width_in_scalars = array_vector_access_width_in_scalars array_kind in + let num_consecutive_elements_being_accessed = + match array_kind with + | Naked_vec128s -> 1 + | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2 + | Naked_int32s | Naked_float32s -> 4 + | Values -> + Misc.fatal_error + "Attempted to load/store a SIMD vector from/to a value array." + | Unboxed_product _ -> + (* CR mshinwell: support unboxed products involving vectors? *) + Misc.fatal_error + "Attempted to load/store a SIMD vector from/to an unboxed product \ + array, which is not yet supported." + in multiple_word_array_access_validity_condition array ~size_int - (Array_kind array_kind) Ptagged_int_index ~width_in_scalars ~index + (Array_kind array_kind) Ptagged_int_index + ~num_consecutive_elements_being_accessed ~index let check_array_vector_access ~dbg ~size_int ~array array_kind ~index primitive : H.expr_primitive = @@ -1053,17 +1081,16 @@ let bigarray_set ~dbg ~unsafe kind layout b indexes value = (* Array accesses *) let array_access_validity_condition array array_kind index - ~(index_kind : L.array_index_kind) ~width_in_scalars ~size_int = + ~(index_kind : L.array_index_kind) ~size_int = [ multiple_word_array_access_validity_condition array ~size_int array_kind - index_kind ~width_in_scalars ~index ] + index_kind ~num_consecutive_elements_being_accessed:1 ~index ] let check_array_access ~dbg ~array array_kind ~index ~index_kind ~size_int primitive : H.expr_primitive = - let width_in_scalars = P.Array_kind_for_length.width_in_scalars array_kind in checked_access ~primitive ~conditions: (array_access_validity_condition array array_kind index ~index_kind - ~width_in_scalars ~size_int) + ~size_int) ~dbg let compute_array_indexes ~index ~num_elts = @@ -1190,7 +1217,7 @@ let rec array_set_unsafe dbg ~array ~index array_kind then Misc.fatal_errorf "Wrong arity for unboxed product array_set_unsafe:@ %a" Debuginfo.print_compact dbg; - (* XXX mshinwell: should these be set in reverse order, to match the + (* CR mshinwell: should these be set in reverse order, to match the evaluation order? *) [ H.Sequence (List.concat_map @@ -1431,10 +1458,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) List.map unbox_float args ), Variadic (Make_array (Values, mutability, mode), args), [K.With_subkind.any_value] ) ])) - | Pmakearray_dynamic (_lambda_array_kind, _mode), _ -> - Misc.fatal_error "Lambda_to_flambda_primitives.convert_lprim: unimplemented" - | Parrayblit _array_set_kind, _ -> - Misc.fatal_error "Lambda_to_flambda_primitives.convert_lprim: unimplemented" + | Pmakearray_dynamic _, _ | Parrayblit _, _ -> + Misc.fatal_error + "Lambda_to_flambda_primitives.convert_lprim: Pmakearray_dynamic and \ + Parrayblit should have been expanded in [Lambda_to_lambda_transforms]" | Popaque layout, [arg] -> opaque layout arg ~middle_end_only:false | Pobj_magic layout, [arg] -> opaque layout arg ~middle_end_only:true | Pduprecord (repr, num_fields), [[arg]] -> @@ -1972,6 +1999,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [Binary (Int_arith (I.Tagged_immediate, Div), arg1, arg2)] | Pdivint Safe, [[arg1]; [arg2]] -> [checked_arith_op ~dbg None Div None arg1 arg2 ~current_region] + | Pmodint Unsafe, [[arg1]; [arg2]] -> + [H.Binary (Int_arith (I.Tagged_immediate, Mod), arg1, arg2)] | Pmodint Safe, [[arg1]; [arg2]] -> [checked_arith_op ~dbg None Mod None arg1 arg2 ~current_region] | Pdivbint { size = Boxed_int32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> @@ -2341,8 +2370,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) "Preinterpret_tagged_int63_as_unboxed_int64 can only be used on 64-bit \ targets"; [Unary (Reinterpret_64_bit_word Tagged_int63_as_unboxed_int64, i)] - | ( ( Pmodint Unsafe - | Pdivbint { is_safe = Unsafe; size = _; mode = _ } + | ( ( Pdivbint { is_safe = Unsafe; size = _; mode = _ } | Pmodbint { is_safe = Unsafe; size = _; mode = _ } | Psetglobal _ | Praise _ | Pccall _ ), _ ) -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli index c678ffe5494..70cbfc63835 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli @@ -17,6 +17,8 @@ module Acc = Closure_conversion_aux.Acc module Expr_with_acc = Closure_conversion_aux.Expr_with_acc +val check_float_array_optimisation_enabled : string -> unit + val convert_and_bind : Acc.t -> big_endian:bool -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml index 7886600e567..8545b061d90 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml @@ -110,7 +110,447 @@ let rec_catch_for_for_loop env loc ident start stop in env, lam -let transform_primitive env (prim : L.primitive) args loc = +type initialize_array_element_width = + | Thirty_two of { zero_init : L.lambda } + | Sixty_four_or_more + +let initialize_array0 env loc ~length array_set_kind width ~(init : L.lambda) + creation_expr = + let array = Ident.create_local "array" in + (* If the element size is 32-bit, zero-initialize the last 64-bit word, to + ensure reproducibility. *) + (* CR mshinwell: why does e.g. caml_make_unboxed_int32_vect not do this? *) + let maybe_zero_init_last_field = + match width with + | Sixty_four_or_more -> L.lambda_unit + | Thirty_two { zero_init } -> + let zero_init_last_field = + L.Lprim + ( Parraysetu (array_set_kind, Ptagged_int_index), + (* [Popaque] is used to conceal the out-of-bounds write. *) + [Lprim (Popaque L.layout_unit, [Lvar array], loc); length; zero_init], + loc ) + in + let length_is_greater_than_zero_and_is_one_mod_two = + L.Lprim + ( Psequand, + [ Lprim (Pintcomp Cgt, [Lconst (L.const_int 0); length], loc); + Lprim + ( Pintcomp Cne, + [ Lprim (Pmodint Unsafe, [length; Lconst (L.const_int 2)], loc); + Lconst (L.const_int 0) ], + loc ) ], + loc ) + in + L.Lifthenelse + ( length_is_greater_than_zero_and_is_one_mod_two, + zero_init_last_field, + L.lambda_unit, + L.layout_unit ) + in + let env, initialize = + let index = Ident.create_local "index" in + rec_catch_for_for_loop env loc index + (Lconst (L.const_int 0)) + (L.Lprim (Psubint, [length; Lconst (L.const_int 1)], loc)) + Upto + (Lprim + ( Parraysetu (array_set_kind, Ptagged_int_index), + [Lvar array; Lvar index; init], + loc )) + in + let term = + L.Llet + ( Strict, + Pvalue { raw_kind = Pgenval; nullable = Non_nullable }, + array, + creation_expr, + Lsequence + (maybe_zero_init_last_field, Lsequence (initialize, Lvar array)) ) + in + env, Transformed term + +let initialize_array env loc ~length array_set_kind width ~init creation_expr = + match init with + | None -> env, Transformed creation_expr + | Some init -> + initialize_array0 env loc ~length array_set_kind width ~init creation_expr + +let makearray_dynamic_singleton name (mode : L.locality_mode) ~length ~init loc + = + let name = + Printf.sprintf "caml_make%s_%s%svect" + (match mode with Alloc_heap -> "" | Alloc_local -> "_local") + name + (if String.length name > 0 then "_" else "") + in + let external_call_desc = + Primitive.make ~name ~alloc:true (* the C stub may raise an exception *) + ~c_builtin:false ~effects:Arbitrary_effects ~coeffects:Has_coeffects + ~native_name:name + ~native_repr_args: + ([Primitive.Prim_global, L.Same_as_ocaml_repr (Base Value)] + @ + match init with + | None -> [] + | Some (init_extern_repr, _) -> [Primitive.Prim_local, init_extern_repr] + ) + ~native_repr_res: + ( (match mode with + | Alloc_heap -> Prim_global + | Alloc_local -> Prim_local), + L.Same_as_ocaml_repr (Base Value) ) + ~is_layout_poly:false + in + L.Lprim + ( Pccall external_call_desc, + ([length] @ match init with None -> [] | Some (_, init) -> [init]), + loc ) + +let makearray_dynamic_singleton_uninitialized name (mode : L.locality_mode) + ~length loc = + makearray_dynamic_singleton name + (mode : L.locality_mode) + ~length ~init:None loc + +let makearray_dynamic_unboxed_products_only_64_bit () = + (* To keep things simple in the C stub as regards array length, we currently + restrict to 64-bit targets. *) + if not (Target_system.is_64_bit ()) + then + Misc.fatal_error + "Cannot compile Pmakearray_dynamic at unboxed product layouts for 32-bit \ + targets" + +let makearray_dynamic_unboxed_product_c_stub ~name (mode : L.locality_mode) = + Primitive.make ~name ~alloc:true (* the C stub may raise an exception *) + ~c_builtin:false ~effects:Arbitrary_effects ~coeffects:Has_coeffects + ~native_name:name + ~native_repr_args: + [ Prim_global, L.Same_as_ocaml_repr (Base Value); + Prim_local, L.Same_as_ocaml_repr (Base Value); + Prim_global, L.Same_as_ocaml_repr (Base Value) ] + ~native_repr_res: + ( (match mode with Alloc_heap -> Prim_global | Alloc_local -> Prim_local), + L.Same_as_ocaml_repr (Base Value) ) + ~is_layout_poly:false + +let makearray_dynamic_non_scannable_unboxed_product env + (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length + ~(init : L.lambda option) loc = + makearray_dynamic_unboxed_products_only_64_bit (); + let is_local = + L.of_bool (match mode with Alloc_heap -> false | Alloc_local -> true) + in + let external_call_desc = + makearray_dynamic_unboxed_product_c_stub + ~name:"caml_makearray_dynamic_non_scannable_unboxed_product" mode + in + let num_components = L.count_initializers_array_kind lambda_array_kind in + (* Note that we don't check the number of unarized arguments against the + layout; we trust the front end. If we wanted to do this, it would have to + be done slightly later, after unarization. *) + (* CR mshinwell: two things were tried here, but one is dirty and the other + needed too much work: + + - CPS convert the primitive arguments before getting here. They may then + have to be converted a second time, in the event that the primitive is + transformed by this file. + + - For this primitive only, have a function passed in here which when + called, does the CPS conversion of the arguments and then escapes using an + exception, returning the number of arguments. This seems dirty. + + Both of these cases introduce complexity as it is necessary to go back to + using an older accumulator during CPS conversion. This is probably fine but + is a real change. *) + let term = + L.( + Lprim + ( Pccall external_call_desc, + [Lconst (L.const_int num_components); is_local; length], + loc )) + in + match init with + | None -> env, Transformed term + | Some init -> + initialize_array0 env loc ~length + (L.array_set_kind + (match mode with + | Alloc_heap -> L.modify_heap + | Alloc_local -> L.modify_maybe_stack) + lambda_array_kind) + (* There is no packing in unboxed product arrays, even if the elements are + all float32# or int32#. *) + Sixty_four_or_more ~init term + +let makearray_dynamic_scannable_unboxed_product0 + (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length ~init + loc = + makearray_dynamic_unboxed_products_only_64_bit (); + (* Trick: use the local stack as a way of getting the variable argument list + to the C function. *) + if not Config.stack_allocation + then + Misc.fatal_error + "Cannot compile Pmakearray_dynamic at unboxed product layouts without \ + stack allocation enabled"; + let args_array = Ident.create_local "args_array" in + let array_layout = L.layout_array lambda_array_kind in + let is_local = + L.of_bool (match mode with Alloc_heap -> false | Alloc_local -> true) + in + let external_call_desc = + makearray_dynamic_unboxed_product_c_stub + ~name:"caml_makearray_dynamic_scannable_unboxed_product" mode + in + (* Note that we don't check the number of unarized arguments against the + layout; we trust the front end. If we wanted to do this, it would have to + be done slightly later, after unarization. *) + let body = + L.Llet + ( Strict, + array_layout, + args_array, + Lprim + ( Pmakearray (lambda_array_kind, Immutable, L.alloc_local), + [init] (* will be unarized when this term is CPS converted *), + loc ), + Lprim + (Pccall external_call_desc, [Lvar args_array; is_local; length], loc) + ) + in + (* We must not add a region if the C stub is going to return a local value, + otherwise we will incorrectly close the region on such live value. *) + Transformed + (match mode with + | Alloc_local -> body + | Alloc_heap -> L.Lregion (body, array_layout)) + +let makearray_dynamic_scannable_unboxed_product env + (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length + ~(init : L.lambda) loc = + let must_be_scanned = + match lambda_array_kind with + | Pgcignorableproductarray _ -> false + | Pgcscannableproductarray kinds -> + let rec must_be_scanned (kind : L.scannable_product_element_kind) = + match kind with + | Pint_scannable -> false + | Paddr_scannable -> true + | Pproduct_scannable kinds -> List.exists must_be_scanned kinds + in + List.exists must_be_scanned kinds + | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray _ + | Punboxedintarray _ | Punboxedvectorarray _ -> + Misc.fatal_errorf + "%s: should have been sent to [makearray_dynamic_singleton]" + (Printlambda.array_kind lambda_array_kind) + in + if must_be_scanned + then + ( env, + makearray_dynamic_scannable_unboxed_product0 lambda_array_kind mode + ~length ~init loc ) + else + makearray_dynamic_non_scannable_unboxed_product env lambda_array_kind mode + ~length ~init:(Some init) loc + +let makearray_dynamic env (lambda_array_kind : L.array_kind) + (mode : L.locality_mode) (has_init : L.has_initializer) args loc : + Env.t * primitive_transform_result = + (* %makearray_dynamic is analogous to (from stdlib/array.ml): + * external create: int -> 'a -> 'a array = "caml_make_vect" + * except that it works on any layout, including unboxed products, at both + * heap and local modes. + * Additionally, if the initializer is omitted, an uninitialized array will + * be returned. Initializers must however be provided when the array kind is + * Pgenarray, Paddrarray, Pintarray, Pfloatarray or Pgcscannableproductarray; + * or when a Pgcignorablearray involves an [int]. (See comment below.) + *) + let dbg = Debuginfo.from_location loc in + let length, init = + match args, has_init with + | [length], Uninitialized -> length, None + | [length; init], With_initializer -> length, Some init + | _, (Uninitialized | With_initializer) -> + Misc.fatal_errorf + "Pmakearray_dynamic takes the (non-unarized) length and optionally an \ + initializer (the latter perhaps of unboxed product layout) according \ + to the setting of [Uninitialized] or [With_initializer]:@ %a" + Debuginfo.print_compact dbg + in + let[@inline] must_have_initializer () = + match init with + | Some init -> init + | None -> ( + match lambda_array_kind with + | Pintarray | Pgcignorableproductarray _ -> + (* If we get here for [Pgcignorableproductarray] then a tagged immediate + is involved: see main [match] below. *) + Misc.fatal_errorf + "Cannot compile Pmakearray_dynamic at layout %s without an \ + initializer; otherwise it might be possible for values of type \ + [int] having incorrect representations to be revealed, thus \ + breaking soundness:@ %a" + (Printlambda.array_kind lambda_array_kind) + Debuginfo.print_compact dbg + | Pgenarray | Paddrarray | Pfloatarray | Punboxedfloatarray _ + | Punboxedintarray _ | Punboxedvectorarray _ | Pgcscannableproductarray _ + -> + Misc.fatal_errorf + "Cannot compile Pmakearray_dynamic at layout %s without an \ + initializer:@ %a" + (Printlambda.array_kind lambda_array_kind) + Debuginfo.print_compact dbg) + in + match lambda_array_kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray -> + let init = must_have_initializer () in + ( env, + Transformed + (makearray_dynamic_singleton "" mode ~length + ~init:(Some (Same_as_ocaml_repr (Base Value), init)) + loc) ) + | Punboxedfloatarray Unboxed_float32 -> + makearray_dynamic_singleton_uninitialized "unboxed_float32" ~length mode loc + |> initialize_array env loc ~length (Punboxedfloatarray_set Unboxed_float32) + (Thirty_two + { zero_init = Lconst (Const_base (Const_unboxed_float32 "0")) }) + ~init + | Punboxedfloatarray Unboxed_float64 -> + makearray_dynamic_singleton_uninitialized "unboxed_float64" ~length mode loc + |> initialize_array env loc ~length (Punboxedfloatarray_set Unboxed_float64) + Sixty_four_or_more ~init + | Punboxedintarray Unboxed_int32 -> + makearray_dynamic_singleton_uninitialized "unboxed_int32" ~length mode loc + |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_int32) + (Thirty_two + { zero_init = Lconst (Const_base (Const_unboxed_int32 0l)) }) + ~init + | Punboxedintarray Unboxed_int64 -> + makearray_dynamic_singleton_uninitialized "unboxed_int64" ~length mode loc + |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_int64) + Sixty_four_or_more ~init + | Punboxedintarray Unboxed_nativeint -> + makearray_dynamic_singleton_uninitialized "unboxed_nativeint" ~length mode + loc + |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_nativeint) + Sixty_four_or_more ~init + | Punboxedvectorarray Unboxed_vec128 -> + makearray_dynamic_singleton_uninitialized "unboxed_vec128" ~length mode loc + |> initialize_array env loc ~length (Punboxedvectorarray_set Unboxed_vec128) + Sixty_four_or_more ~init + | Pgcscannableproductarray _ -> + let init = must_have_initializer () in + makearray_dynamic_scannable_unboxed_product env lambda_array_kind mode + ~length ~init loc + | Pgcignorableproductarray ignorable -> + (* Care: all (unarized) elements that are valid OCaml values, in this case + of type [int] or equivalent, must be initialized. This is to ensure + soundness in the event of a read occurring prior to initialization (e.g. + by ensuring that values without the bottom bit set cannot be returned at + type [int]). *) + let init = + if List.exists L.ignorable_product_element_kind_involves_int ignorable + then Some (must_have_initializer ()) + else init + in + makearray_dynamic_non_scannable_unboxed_product env lambda_array_kind mode + ~length ~init loc + +let arrayblit env ~(src_mutability : L.mutable_flag) + ~(dst_array_set_kind : L.array_set_kind) args loc = + let src_array_ref_kind = + (* We don't expect any allocation (e.g. occurring from the reading of a + [float array]) to persist after simplification. We use [alloc_local] just + in case that simplification doesn't happen for some reason (this seems + unlikely). *) + L.array_ref_kind_of_array_set_kind dst_array_set_kind L.alloc_local + in + match args with + | [src_expr; src_start_pos_expr; dst_expr; dst_start_pos_expr; length_expr] -> + (* Care: the [args] are arbitrary Lambda expressions, so need to be + [let]-bound *) + let id = Ident.create_local in + let bind = L.bind_with_layout in + let src = id "src" in + let src_start_pos = id "src_start_pos" in + let dst = id "dst" in + let dst_start_pos = id "dst_start_pos" in + let length = id "length" in + (* CR mshinwell: support indexing by other types apart from [int] *) + let src_end_pos_exclusive = + L.Lprim (Paddint, [Lvar src_start_pos; Lvar length], loc) + in + let src_end_pos_inclusive = + L.Lprim (Psubint, [src_end_pos_exclusive; Lconst (L.const_int 1)], loc) + in + let dst_start_pos_minus_src_start_pos = + L.Lprim (Psubint, [Lvar dst_start_pos; Lvar src_start_pos], loc) + in + let dst_start_pos_minus_src_start_pos_var = + Ident.create_local "dst_start_pos_minus_src_start_pos" + in + let must_copy_backwards = + L.Lprim (Pintcomp Cgt, [Lvar dst_start_pos; Lvar src_start_pos], loc) + in + let make_loop env (direction : Asttypes.direction_flag) = + let src_index = Ident.create_local "index" in + let start_pos, end_pos = + match direction with + | Upto -> L.Lvar src_start_pos, src_end_pos_inclusive + | Downto -> src_end_pos_inclusive, L.Lvar src_start_pos + in + rec_catch_for_for_loop env loc src_index start_pos end_pos direction + (Lprim + ( Parraysetu (dst_array_set_kind, Ptagged_int_index), + [ Lvar dst; + Lprim + ( Paddint, + [Lvar src_index; dst_start_pos_minus_src_start_pos], + loc ); + Lprim + ( Parrayrefu + ( src_array_ref_kind, + Ptagged_int_index, + match src_mutability with + | Immutable | Immutable_unique -> Immutable + | Mutable -> Mutable ), + [Lvar src; Lvar src_index], + loc ) ], + loc )) + in + let env, copy_backwards = make_loop env Downto in + let env, copy_forwards = make_loop env Upto in + let body = + (* The region is expected to be redundant (see comment above about + modes). *) + L.Lregion + ( L.Lifthenelse + (must_copy_backwards, copy_backwards, copy_forwards, L.layout_unit), + L.layout_unit ) + in + let expr = + (* Preserve right-to-left evaluation order. *) + bind Strict (length, L.layout_int) length_expr + @@ bind Strict (dst_start_pos, L.layout_int) dst_start_pos_expr + @@ bind Strict (dst, L.layout_any_value) dst_expr + @@ bind Strict (src_start_pos, L.layout_int) src_start_pos_expr + @@ bind Strict (src, L.layout_any_value) src_expr + @@ bind Strict + (dst_start_pos_minus_src_start_pos_var, L.layout_int) + dst_start_pos_minus_src_start_pos body + in + env, Transformed expr + | _ -> + Misc.fatal_errorf + "Wrong arity for Parrayblit{,_immut} (expected src, src_offset, \ + dst_offset and length):@ %a" + Debuginfo.print_compact + (Debuginfo.from_location loc) + +let transform_primitive0 env (prim : L.primitive) args loc = match prim, args with | Psequor, [arg1; arg2] -> let const_true = Ident.create_local "const_true" in @@ -251,3 +691,12 @@ let transform_primitive env (prim : L.primitive) args loc = (see translprim).") | _, _ -> Primitive (prim, args, loc) [@@ocaml.warning "-fragile-match"] + +let transform_primitive env (prim : L.primitive) args loc = + match prim with + | Pmakearray_dynamic (lambda_array_kind, mode, has_init) -> + makearray_dynamic env lambda_array_kind mode has_init args loc + | Parrayblit { src_mutability; dst_array_set_kind } -> + arrayblit env ~src_mutability ~dst_array_set_kind args loc + | _ -> env, transform_primitive0 env prim args loc + [@@ocaml.warning "-fragile-match"] diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli index f7a0bd73d04..4ea169908bb 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli @@ -44,6 +44,7 @@ val switch_for_if_then_else : val transform_primitive : Lambda_to_flambda_env.t -> Lambda.primitive -> + (* CR mshinwell: consider [Ident.t list] instead for the arguments. *) Lambda.lambda list -> Lambda.scoped_location -> - primitive_transform_result + Lambda_to_flambda_env.t * primitive_transform_result diff --git a/runtime/array.c b/runtime/array.c index a58b16c1cc7..419645d85db 100644 --- a/runtime/array.c +++ b/runtime/array.c @@ -406,6 +406,18 @@ CAMLprim value caml_floatarray_create_local(value len) return caml_alloc_local (wosize, Double_array_tag); } +// Stubs with consistent naming: + +CAMLprim value caml_make_unboxed_float64_vect(value len) +{ + return caml_floatarray_create(len); +} + +CAMLprim value caml_make_local_unboxed_float64_vect(value len) +{ + return caml_floatarray_create_local(len); +} + /* [len] is a [value] representing number of words or floats */ static value make_vect_gen(value len, value init, int local) { @@ -453,7 +465,8 @@ static value make_vect_gen(value len, value init, int local) for (i = 0; i < size; i++) Field(res, i) = init; } } - /* Give the GC a chance to run, and run memprof callbacks */ + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ if (!local) caml_process_pending_actions (); CAMLreturn (res); } @@ -469,6 +482,151 @@ CAMLprim value caml_make_local_vect(value len, value init) return make_vect_gen(len, init, 1); } +CAMLprim value caml_makearray_dynamic_non_scannable_unboxed_product( + value v_num_components, value v_is_local, + value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + // This function is only used for native code. + + CAMLparam0(); + CAMLlocal1(res); + + mlsize_t num_components = Long_val(v_num_components); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + mlsize_t size; + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + // These arrays are always mixed blocks without packing. + // This currently differs from e.g. int32# array, which is allocated as a + // custom block, and is packed. + int reserved = Reserved_mixed_block_scannable_wosize_native(0); + + size = non_unarized_length * num_components; + if (size == 0) { + res = Atom(0); + } else if (num_components < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local_reserved(size, tag, reserved); + } else if (size <= Max_young_wosize) { + res = caml_alloc_small_with_reserved(size, tag, reserved); + } else { + res = caml_alloc_shr_reserved(size, tag, reserved); + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + // CR mshinwell: the other functions which allocate unboxed number arrays + // should also do this + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + +CAMLprim value caml_makearray_dynamic_scannable_unboxed_product( + value v_init, value v_is_local, value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + + CAMLparam1(v_init); + CAMLlocal1(res); + + mlsize_t num_initializers = Wosize_val(v_init); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + + mlsize_t size, i; + + // N.B. [v_init] may be on the local stack! + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + + size = non_unarized_length * num_initializers; + if (size == 0) { + res = Atom(0); + } else if (num_initializers < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else if (size <= Max_young_wosize) { + res = caml_alloc_small(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else { + int move_init_to_major = 0; + for (mlsize_t i = 0; i < num_initializers; i++) { + if (Is_block(Field(v_init, i)) && Is_young(Field(v_init, i))) { + move_init_to_major = 1; + } + } + if (move_init_to_major) { + /* We don't want to create so many major-to-minor references, + so the contents of [v_init] are moved to the major heap by doing + a minor GC. */ + /* CR mslater/mshinwell: Why is this better than adding them to the + remembered set with caml_initialize? See discussion in a + conversation on: + https://github.com/ocaml-flambda/flambda-backend/pull/3317 + */ + CAML_EV_COUNTER (EV_C_FORCE_MINOR_MAKE_VECT, 1); + caml_minor_collection (); + } +#ifdef DEBUG + for (mlsize_t i = 0; i < num_initializers; i++) { + CAMLassert(!(Is_block(Field(v_init, i)) && Is_young(Field(v_init, i)))); + } +#endif + res = caml_alloc_shr(size, tag); + /* We now know that everything in [v_init] is not in the minor heap, so + there is no need to call [caml_initialize]. */ + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + /* [len] is a [value] representing number of floats */ /* [ int -> float array ] */ CAMLprim value caml_make_float_vect(value len) @@ -492,18 +650,34 @@ CAMLprim value caml_make_float_vect(value len) #endif } -CAMLprim value caml_make_unboxed_int32_vect(value len) +static value caml_make_unboxed_int32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int32_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int32_array_wosize) + caml_invalid_argument("Array.make"); /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_int32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + struct custom_operations* ops = + &caml_unboxed_int32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 1); } CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) @@ -511,14 +685,28 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int32(0)); } -CAMLprim value caml_make_unboxed_int64_vect(value len) +static value caml_make_unboxed_int64_vect0(value len, int local) { mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int64_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int64_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_int64_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 1); } CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) @@ -526,16 +714,30 @@ CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int64(0)); } -CAMLprim value caml_make_unboxed_nativeint_vect(value len) +static value caml_make_unboxed_nativeint_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_nativeint_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_nativeint_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_nativeint_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 1); } CAMLprim value caml_make_unboxed_nativeint_vect_bytecode(value len) diff --git a/runtime/caml/custom.h b/runtime/caml/custom.h index 127d8247abd..509a85d2034 100644 --- a/runtime/caml/custom.h +++ b/runtime/caml/custom.h @@ -59,6 +59,13 @@ CAMLextern value caml_alloc_custom(const struct custom_operations * ops, mlsize_t mem, /*resources consumed*/ mlsize_t max /*max resources*/); +// The local version will fail if a finalizer is supplied in the [ops], +// since finalizers on locally-allocated values are not yet supported. +CAMLextern value caml_alloc_custom_local(const struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + /* [caml_alloc_custom_mem] allocates a custom block with dependent memory (memory outside the heap that will be reclaimed when the block is finalized). If [mem] is greater than [custom_minor_max_size] (see gc.mli) diff --git a/runtime/caml/memory.h b/runtime/caml/memory.h index 7c3359b7e86..793aed1a28b 100644 --- a/runtime/caml/memory.h +++ b/runtime/caml/memory.h @@ -37,6 +37,7 @@ CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); CAMLextern value caml_alloc_shr_noexc(mlsize_t wosize, tag_t); CAMLextern value caml_alloc_shr_reserved (mlsize_t, tag_t, reserved_t); CAMLextern value caml_alloc_local(mlsize_t, tag_t); +CAMLextern value caml_alloc_local_reserved(mlsize_t, tag_t, reserved_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_adjust_minor_gc_speed (mlsize_t, mlsize_t); diff --git a/runtime/custom.c b/runtime/custom.c index 80f1191c08f..d277740df05 100644 --- a/runtime/custom.c +++ b/runtime/custom.c @@ -67,14 +67,20 @@ static value alloc_custom_gen (const struct custom_operations * ops, mlsize_t mem, mlsize_t max_major, mlsize_t max_minor, - int minor_ok) + int minor_ok, + int local) { mlsize_t wosize; CAMLparam0(); CAMLlocal1(result); wosize = 1 + (bsz + sizeof(value) - 1) / sizeof(value); - if (wosize <= Max_young_wosize && minor_ok) { + if (local) { + CAMLassert(ops->finalize == NULL); + result = caml_alloc_local(wosize, Custom_tag); + Custom_ops_val(result) = ops; + } + else if (wosize <= Max_young_wosize && minor_ok) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; if (ops->finalize != NULL || mem != 0) { @@ -102,14 +108,35 @@ Caml_inline mlsize_t get_max_minor (void) Bsize_wsize (Caml_state->minor_heap_wsz) / 100 * caml_custom_minor_ratio; } +static value caml_alloc_custom0(const struct custom_operations * ops, + uintnat bsz, + mlsize_t mem, + mlsize_t max, + int local) +{ + mlsize_t max_major = max; + mlsize_t max_minor = max == 0 ? get_max_minor() : max; + return alloc_custom_gen (ops, bsz, mem, max_major, max_minor, 1, local); +} + CAMLexport value caml_alloc_custom(const struct custom_operations * ops, uintnat bsz, mlsize_t mem, mlsize_t max) { - mlsize_t max_major = max; - mlsize_t max_minor = max == 0 ? get_max_minor() : max; - return alloc_custom_gen (ops, bsz, mem, max_major, max_minor, 1); + return caml_alloc_custom0(ops, bsz, mem, max, 0); +} + +CAMLexport value caml_alloc_custom_local(const struct custom_operations * ops, + uintnat bsz, + mlsize_t mem, + mlsize_t max) +{ + if (ops->finalize != NULL) + caml_invalid_argument( + "caml_alloc_custom_local: finalizers not supported"); + + return caml_alloc_custom0(ops, bsz, mem, max, 1); } CAMLexport value caml_alloc_custom_mem(const struct custom_operations * ops, @@ -124,7 +151,7 @@ CAMLexport value caml_alloc_custom_mem(const struct custom_operations * ops, max_minor_single = max_minor * caml_custom_minor_max_bsz / 100; } value v = alloc_custom_gen (ops, bsz, mem, 0, - max_minor, (mem < max_minor_single)); + max_minor, (mem < max_minor_single), 0); size_t mem_words = (mem + sizeof(value) - 1) / sizeof(value); caml_memprof_sample_block(v, mem_words, mem_words, CAML_MEMPROF_SRC_CUSTOM); return v; diff --git a/runtime/float32.c b/runtime/float32.c index da47e0af1bf..e57e94e1e64 100644 --- a/runtime/float32.c +++ b/runtime/float32.c @@ -853,7 +853,7 @@ CAMLexport const struct custom_operations caml_unboxed_float32_array_ops[2] = { custom_fixed_length_default }, }; -CAMLprim value caml_make_unboxed_float32_vect(value len) +static value caml_make_unboxed_float32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ @@ -863,8 +863,23 @@ CAMLprim value caml_make_unboxed_float32_vect(value len) /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + const struct custom_operations* ops = + &caml_unboxed_float32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 1); } CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) diff --git a/runtime/memory.c b/runtime/memory.c index fade3ec6c55..f867a21a779 100644 --- a/runtime/memory.c +++ b/runtime/memory.c @@ -531,7 +531,8 @@ void caml_local_realloc(void) CAMLassert(Caml_state->local_limit <= Caml_state->local_sp); } -CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, + reserved_t reserved) { #if defined(NATIVE_CODE) && defined(STACK_ALLOCATION) intnat sp = Caml_state->local_sp; @@ -541,21 +542,26 @@ CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) if (sp < Caml_state->local_limit) caml_local_realloc(); hp = (header_t*)((char*)Caml_state->local_top + sp); - *hp = Make_header(wosize, tag, NOT_MARKABLE); + *hp = Make_header_with_reserved(wosize, tag, NOT_MARKABLE, reserved); return Val_hp(hp); #else if (wosize <= Max_young_wosize) { - return caml_alloc_small(wosize, tag); + return caml_alloc_small_with_reserved(wosize, tag, reserved); } else { /* The return value is initialised directly using Field. This is invalid if it may create major -> minor pointers. So, perform a minor GC to prevent this. (See caml_make_vect) */ caml_minor_collection(); - return caml_alloc_shr(wosize, tag); + return caml_alloc_shr_reserved(wosize, tag, reserved); } #endif } +CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +{ + return caml_alloc_local_reserved(wosize, tag, 0); +} + CAMLprim value caml_local_stack_offset(value blk) { #ifdef NATIVE_CODE diff --git a/runtime/simd.c b/runtime/simd.c index 0e1e6129f26..3188184ef68 100644 --- a/runtime/simd.c +++ b/runtime/simd.c @@ -75,20 +75,37 @@ CAMLprim value caml_unboxed_vec128_vect_blit(value a1, value ofs1, value a2, return Val_unit; } -CAMLprim value caml_make_unboxed_vec128_vect(value len) { - /* This is only used on 64-bit targets. */ - - mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_vec128_array_wosize) caml_invalid_argument("Array.make"); +static value caml_make_unboxed_vec128_vect0(value len, int local) +{ + /* This is only used on 64-bit targets. */ + + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_unboxed_vec128_array_wosize) + caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = num_elements * 2; + + if (local) + return caml_alloc_custom_local(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); +} - /* [num_fields] does not include the custom operations field. */ - mlsize_t num_fields = num_elements * 2; +CAMLprim value caml_make_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 0); +} - return caml_alloc_custom(&caml_unboxed_vec128_array_ops, num_fields * sizeof(value), 0, 0); +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 1); } CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { - caml_failwith("SIMD is not supported in bytecode mode."); + caml_failwith("SIMD is not supported on this platform."); } #else @@ -102,6 +119,10 @@ CAMLprim value caml_make_unboxed_vec128_vect(value len) { caml_failwith("SIMD is not supported on this platform."); } +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) { + caml_failwith("SIMD is not supported on this platform."); +} + CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { caml_failwith("SIMD is not supported on this platform."); } diff --git a/runtime4/array.c b/runtime4/array.c index ae3306028f6..2d2d67e8f09 100644 --- a/runtime4/array.c +++ b/runtime4/array.c @@ -414,6 +414,18 @@ CAMLprim value caml_floatarray_create_local(value len) return caml_alloc_local (wosize, Double_array_tag); } +// Stubs with consistent naming: + +CAMLprim value caml_make_unboxed_float64_vect(value len) +{ + return caml_floatarray_create(len); +} + +CAMLprim value caml_make_local_unboxed_float64_vect(value len) +{ + return caml_floatarray_create_local(len); +} + /* [len] is a [value] representing number of words or floats */ static value make_vect_gen(value len, value init, int local) { @@ -462,12 +474,12 @@ static value make_vect_gen(value len, value init, int local) for (i = 0; i < size; i++) Field(res, i) = init; } } - // Give the GC a chance to run, and run memprof callbacks + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ if (!local) caml_process_pending_actions (); CAMLreturn (res); } - CAMLprim value caml_make_vect(value len, value init) { return make_vect_gen(len, init, 0); @@ -478,6 +490,151 @@ CAMLprim value caml_make_local_vect(value len, value init) return make_vect_gen(len, init, 1); } +CAMLprim value caml_makearray_dynamic_non_scannable_unboxed_product( + value v_num_components, value v_is_local, + value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + // This function is only used for native code. + + CAMLparam0(); + CAMLlocal1(res); + + mlsize_t num_components = Long_val(v_num_components); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + mlsize_t size; + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + // These arrays are always mixed blocks without packing. + // This currently differs from e.g. int32# array, which is allocated as a + // custom block, and is packed. + int reserved = Reserved_mixed_block_scannable_wosize_native(0); + + size = non_unarized_length * num_components; + if (size == 0) { + res = Atom(0); + } else if (num_components < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local_reserved(size, tag, reserved); + } else if (size <= Max_young_wosize) { + res = caml_alloc_small_with_reserved(size, tag, reserved); + } else { + res = caml_alloc_shr_reserved(size, tag, reserved); + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + // CR mshinwell: the other functions which allocate unboxed number arrays + // should also do this + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + +CAMLprim value caml_makearray_dynamic_scannable_unboxed_product( + value v_init, value v_is_local, value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + + CAMLparam1(v_init); + CAMLlocal1(res); + + mlsize_t num_initializers = Wosize_val(v_init); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + + mlsize_t size, i; + + // N.B. [v_init] may be on the local stack! + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + + size = non_unarized_length * num_initializers; + if (size == 0) { + res = Atom(0); + } else if (num_initializers < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else if (size <= Max_young_wosize) { + res = caml_alloc_small(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else { + int move_init_to_major = 0; + for (mlsize_t i = 0; i < num_initializers; i++) { + if (Is_block(Field(v_init, i)) && Is_young(Field(v_init, i))) { + move_init_to_major = 1; + } + } + if (move_init_to_major) { + /* We don't want to create so many major-to-minor references, + so the contents of [v_init] are moved to the major heap by doing + a minor GC. */ + /* CR mslater/mshinwell: Why is this better than adding them to the + remembered set with caml_initialize? See discussion in a + conversation on: + https://github.com/ocaml-flambda/flambda-backend/pull/3317 + */ + CAML_EV_COUNTER (EV_C_FORCE_MINOR_MAKE_VECT, 1); + caml_minor_collection (); + } +#ifdef DEBUG + for (mlsize_t i = 0; i < num_initializers; i++) { + CAMLassert(!(Is_block(Field(v_init, i)) && Is_young(Field(v_init, i)))); + } +#endif + res = caml_alloc_shr(size, tag); + /* We now know that everything in [v_init] is not in the minor heap, so + there is no need to call [caml_initialize]. */ + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + /* [len] is a [value] representing number of floats */ /* [ int -> float array ] */ CAMLprim value caml_make_float_vect(value len) @@ -494,18 +651,34 @@ CAMLprim value caml_make_float_vect(value len) #endif } -CAMLprim value caml_make_unboxed_int32_vect(value len) +static value caml_make_unboxed_int32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int32_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int32_array_wosize) + caml_invalid_argument("Array.make"); /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_int32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + struct custom_operations* ops = + &caml_unboxed_int32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 1); } CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) @@ -513,14 +686,28 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int32(0)); } -CAMLprim value caml_make_unboxed_int64_vect(value len) +static value caml_make_unboxed_int64_vect0(value len, int local) { mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int64_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int64_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_int64_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 1); } CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) @@ -528,16 +715,30 @@ CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int64(0)); } -CAMLprim value caml_make_unboxed_nativeint_vect(value len) +static value caml_make_unboxed_nativeint_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_nativeint_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_nativeint_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_nativeint_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 1); } CAMLprim value caml_make_unboxed_nativeint_vect_bytecode(value len) @@ -963,3 +1164,6 @@ CAMLprim value caml_array_unsafe_set_indexed_by_nativeint(value, value, value); Array_access_index_by(int64, int64_t, Int64_val) Array_access_index_by(int32, int32_t, Int32_val) Array_access_index_by(nativeint, intnat, Nativeint_val) + +// XXX mshinwell: add the %makearray_dynamic prims here for runtime4 +// once the runtime5 versions have been reviewed and tested diff --git a/runtime4/caml/custom.h b/runtime4/caml/custom.h index 62dec5c6302..c319276c3f7 100644 --- a/runtime4/caml/custom.h +++ b/runtime4/caml/custom.h @@ -61,6 +61,13 @@ CAMLextern value caml_alloc_custom(struct custom_operations * ops, mlsize_t mem, /*resources consumed*/ mlsize_t max /*max resources*/); +// The local version will fail if a finalizer is supplied in the [ops], +// since finalizers on locally-allocated values are not yet supported. +CAMLextern value caml_alloc_custom_local(struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + CAMLextern value caml_alloc_custom_mem(struct custom_operations * ops, uintnat size, /*size in bytes*/ mlsize_t mem /*memory consumed*/); diff --git a/runtime4/caml/memory.h b/runtime4/caml/memory.h index e5204f92f96..d5c70413cbd 100644 --- a/runtime4/caml/memory.h +++ b/runtime4/caml/memory.h @@ -55,6 +55,7 @@ CAMLextern value caml_alloc_shr_no_track_noexc (mlsize_t, tag_t); CAMLextern value caml_alloc_shr_for_minor_gc (mlsize_t, tag_t, header_t); CAMLextern value caml_alloc_local(mlsize_t, tag_t); +CAMLextern value caml_alloc_local_reserved(mlsize_t, tag_t, reserved_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); diff --git a/runtime4/custom.c b/runtime4/custom.c index 37d88f48cdc..48595a91518 100644 --- a/runtime4/custom.c +++ b/runtime4/custom.c @@ -35,7 +35,8 @@ static value alloc_custom_gen (struct custom_operations * ops, mlsize_t mem, mlsize_t max_major, mlsize_t mem_minor, - mlsize_t max_minor) + mlsize_t max_minor, + int local) { mlsize_t wosize; CAMLparam0(); @@ -46,7 +47,12 @@ static value alloc_custom_gen (struct custom_operations * ops, CAMLassert (mem_minor <= mem); wosize = 1 + (bsz + sizeof(value) - 1) / sizeof(value); - if (wosize <= Max_young_wosize) { + if (local) { + CAMLassert(ops->finalize == NULL); + result = caml_alloc_local(wosize, Custom_tag); + Custom_ops_val(result) = ops; + } + else if (wosize <= Max_young_wosize) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; if (ops->finalize != NULL || mem != 0) { @@ -81,7 +87,19 @@ CAMLexport value caml_alloc_custom(struct custom_operations * ops, mlsize_t mem, mlsize_t max) { - return alloc_custom_gen (ops, bsz, mem, max, mem, max); + return alloc_custom_gen (ops, bsz, mem, max, mem, max, 0); +} + +CAMLexport value caml_alloc_custom_local(struct custom_operations * ops, + uintnat bsz, + mlsize_t mem, + mlsize_t max) +{ + if (ops->finalize != NULL) + caml_invalid_argument( + "caml_alloc_custom_local: finalizers not supported"); + + return alloc_custom_gen (ops, bsz, mem, max, mem, max, 1); } CAMLexport value caml_alloc_custom_mem(struct custom_operations * ops, @@ -103,7 +121,8 @@ CAMLexport value caml_alloc_custom_mem(struct custom_operations * ops, Bsize_wsize (Caml_state->stat_heap_wsz) / 150 * caml_custom_major_ratio; mlsize_t max_minor = Bsize_wsize (Caml_state->minor_heap_wsz) / 100 * caml_custom_minor_ratio; - value v = alloc_custom_gen (ops, bsz, mem, max_major, mem_minor, max_minor); + value v = + alloc_custom_gen (ops, bsz, mem, max_major, mem_minor, max_minor, 0); caml_memprof_track_custom(v, mem); return v; } diff --git a/runtime4/float32.c b/runtime4/float32.c index 8ae164e38e8..3fb8654d4a5 100644 --- a/runtime4/float32.c +++ b/runtime4/float32.c @@ -852,7 +852,7 @@ CAMLexport struct custom_operations caml_unboxed_float32_array_ops[2] = { custom_fixed_length_default }, }; -CAMLprim value caml_make_unboxed_float32_vect(value len) +static value caml_make_unboxed_float32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ @@ -862,8 +862,23 @@ CAMLprim value caml_make_unboxed_float32_vect(value len) /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + struct custom_operations* ops = + &caml_unboxed_float32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 1); } CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) diff --git a/runtime4/memory.c b/runtime4/memory.c index 1d2081d0bfb..195e98c7877 100644 --- a/runtime4/memory.c +++ b/runtime4/memory.c @@ -798,7 +798,8 @@ void caml_local_realloc(void) CAMLassert(Caml_state->local_limit <= Caml_state->local_sp); } -CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, + reserved_t reserved) { #if defined(NATIVE_CODE) && defined(STACK_ALLOCATION) intnat sp = Caml_state->local_sp; @@ -808,21 +809,26 @@ CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) if (sp < Caml_state->local_limit) caml_local_realloc(); hp = (header_t*)((char*)Caml_state->local_top + sp); - *hp = Make_header(wosize, tag, Local_unmarked); + *hp = Make_header_with_profinfo(wosize, tag, Local_unmarked, reserved); return Val_hp(hp); #else if (wosize <= Max_young_wosize) { - return caml_alloc_small(wosize, tag); + return caml_alloc_small_with_reserved(wosize, tag, reserved); } else { /* The return value is initialised directly using Field. This is invalid if it may create major -> minor pointers. So, perform a minor GC to prevent this. (See caml_make_vect) */ caml_minor_collection(); - return caml_alloc_shr(wosize, tag); + return caml_alloc_shr_reserved(wosize, tag, reserved); } #endif } +CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +{ + return caml_alloc_local_reserved(wosize, tag, 0); +} + CAMLprim value caml_local_stack_offset(value blk) { #ifdef NATIVE_CODE diff --git a/runtime4/simd.c b/runtime4/simd.c index a9ae173772b..48986e06b2b 100644 --- a/runtime4/simd.c +++ b/runtime4/simd.c @@ -73,20 +73,37 @@ CAMLprim value caml_unboxed_vec128_vect_blit(value a1, value ofs1, value a2, return Val_unit; } -CAMLprim value caml_make_unboxed_vec128_vect(value len) { - /* This is only used on 64-bit targets. */ - - mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_vec128_array_wosize) caml_invalid_argument("Array.make"); +static value caml_make_unboxed_vec128_vect0(value len, int local) +{ + /* This is only used on 64-bit targets. */ + + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_unboxed_vec128_array_wosize) + caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = num_elements * 2; + + if (local) + return caml_alloc_custom_local(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); +} - /* [num_fields] does not include the custom operations field. */ - mlsize_t num_fields = num_elements * 2; +CAMLprim value caml_make_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 0); +} - return caml_alloc_custom(&caml_unboxed_vec128_array_ops, num_fields * sizeof(value), 0, 0); +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 1); } CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { - caml_failwith("SIMD is not supported in bytecode mode."); + caml_failwith("SIMD is not supported on this platform."); } #else @@ -100,6 +117,10 @@ CAMLprim value caml_make_unboxed_vec128_vect(value len) { caml_failwith("SIMD is not supported on this platform."); } +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) { + caml_failwith("SIMD is not supported on this platform."); +} + CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { caml_failwith("SIMD is not supported on this platform."); } diff --git a/testsuite/tests/typing-layouts-arrays/README.md b/testsuite/tests/typing-layouts-arrays/README.md new file mode 100644 index 00000000000..14c5a717d58 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/README.md @@ -0,0 +1,34 @@ +This directory has tests for arrays of unboxed types. The tests assume the array +contains something that is like a number. + +Using the test framework here still involves a fair amount of copy and paste to +build your new test. This is mainly because we don't have layout polymorphism, +so it's not really possible to build it as one nice big functor. Hopefully we +can improve it in the future. + +## Basic use + +The files `gen_u_array.ml` and `test_gen_u_array.ml` contain the basic +framework. Rather than reading them, you are probably better off looking at an +example. E.g., see `test_int64_u_array.ml`. + +## Errors + +The testing framework is not very helpful in the event of errors - you'll get an +assertion failure with an uninformative backtrace. One way to debug is to +copy the framework and your test file elsewhere, compile and run it as a normal +ocaml program, then comment out parts of the big test functor from +`test_gen_u_array.ml` until you locate the line causing the error. This should +be improved. + +## Unboxed products + +The file `gen_product_array_helpers.ml` has additional infrastructure for +testing arrays of unboxed products. To add a new test, copy one of the existing +ones (e.g., `test_ignorable_product_array_1.ml`) and follow the instructions +in its comments about which parts you need to edit. + +Note that tests whose filename contains `with_uninit` use +`%makearray_dynamic_uninit` to create arrays, while other tests using this +infrastructure use `%makearray_dynamic`. + diff --git a/testsuite/tests/typing-layouts-arrays/basics_alpha.ml b/testsuite/tests/typing-layouts-arrays/basics_alpha.ml index 4b6074016e1..b52edd91f95 100644 --- a/testsuite/tests/typing-layouts-arrays/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-arrays/basics_alpha.ml @@ -362,3 +362,302 @@ Error: This expression has type "float32#" because it's the type of an array element, chosen to have layout value. |}] + +(* Test 8: makearraydynamic_uninit *) + +external[@layout_poly] makearray_dynamic_uninit_local + : ('a : any_non_null) . int -> 'a array @ local = "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_uninit + : ('a : any_non_null) . int -> 'a array = "%makearray_dynamic_uninit" +[%%expect{| +external makearray_dynamic_uninit_local : + ('a : any_non_null). int -> local_ 'a array = "%makearray_dynamic_uninit" + [@@layout_poly] +external makearray_dynamic_uninit : ('a : any_non_null). int -> 'a array + = "%makearray_dynamic_uninit" [@@layout_poly] +|}] + +type ('a : any) with_i64s = #( int64# * 'a * int64# ) + +type ok_1 = #(int64# * int32#) +type ok_2 = float# with_i64s + +type bad_1 = #(int * int32#) +type bad_2 = int +type bad_3 = A | B | C +type bad_4 = #{ a: int64# ; enum : bad_3 } +type bad_5 = bad_3 with_i64s +type bad_6 = #(float * #(float * float) * #(float * #(float * float * float))) +type bad_7 = #{ i : int64# ; bad_4 : bad_4 ; j : int64# } +[%%expect{| +type ('a : any) with_i64s = #(int64# * 'a * int64#) +type ok_1 = #(int64# * int32#) +type ok_2 = float# with_i64s +type bad_1 = #(int * int32#) +type bad_2 = int +type bad_3 = A | B | C +type bad_4 = #{ a : int64#; enum : bad_3; } +type bad_5 = bad_3 with_i64s +type bad_6 = + #(float * #(float * float) * #(float * #(float * float * float))) +type bad_7 = #{ i : int64#; bad_4 : bad_4; j : int64#; } +|}] + +(* Allowed usages *) + +let _ = + (makearray_dynamic_uninit 0 : float# array) +[%%expect{| +- : float# array = [||] +|}] + +let _ = + (makearray_dynamic_uninit 0 : ok_1 array) +[%%expect{| +- : ok_1 array = [||] +|}] + +let _ = + (makearray_dynamic_uninit 0 : ok_2 array) +[%%expect{| +- : ok_2 array = [||] +|}] + +(* Disallowed usages *) + +let _ = + (makearray_dynamic_uninit 0 : int array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : int array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : float array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : float array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : #(int64# * int) array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : #(int64# * int) array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_1 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_1 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_2 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_2 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_3 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_3 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_4 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_4 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_5 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_5 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_6 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_6 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_7 array) +[%%expect{| +Line 2, characters 3-29: +2 | (makearray_dynamic_uninit 0 : bad_7 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +(* Allowed usages (local) *) + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : ok_1 array) in + () +[%%expect{| +- : unit = () +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : ok_2 array) in + () +[%%expect{| +- : unit = () +|}] + +(* Disallowed usages (local) *) + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : int array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : int array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : #(int64# * int) array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : #(int64# * int) array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_1 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_1 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_2 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_2 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_3 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_3 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_4 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_4 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_5 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_5 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_6 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_6 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_7 array) in + () +[%%expect{| +Line 2, characters 11-43: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_7 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] diff --git a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml new file mode 100644 index 00000000000..296563970a0 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml @@ -0,0 +1,353 @@ +module type Element_intf = Test_gen_u_array.Element_intf + +type 'a elem = + | Number : { ops : (module Element_intf with type t = 'a) } -> 'a elem + | Option : 'a elem -> ('a option) elem + | Tup2 : 'a1 elem * 'a2 elem -> ('a1 * 'a2) elem + | Tup3 : 'a1 elem * 'a2 elem * 'a3 elem -> ('a1 * 'a2 * 'a3) elem + | Tup4 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem + -> ('a1 * 'a2 * 'a3 * 'a4) elem + | Tup5 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) elem + | Tup6 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem * 'a6 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) elem + +module Int_elem : Element_intf with type t = int = +struct + include Int + let of_int x = x + let max_val = max_int + let min_val = min_int + let rand = Random.full_int + let print i = Printf.printf "%d" i +end + +let int_elem = Number { ops = (module Int_elem) } + +module Int32_elem : Element_intf with type t = int32 = +struct + include Int32 + let max_val = max_int + let min_val = min_int + let rand = Random.int32 + let print i = Printf.printf "%ld" i +end + +let int32_elem = Number { ops = (module Int32_elem) } + +module Int64_elem : Element_intf with type t = int64 = +struct + include Int64 + let max_val = max_int + let min_val = min_int + let rand = Random.int64 + let print i = Printf.printf "%Ld" i +end + +let int64_elem = Number { ops = (module Int64_elem) } + +module Nativeint_elem : Element_intf with type t = nativeint = +struct + include Nativeint + let max_val = max_int + let min_val = min_int + let rand = Random.nativeint + let print i = Printf.printf "%nd" i +end + +let nativeint_elem = Number { ops = (module Nativeint_elem) } + +module Float_elem : Element_intf with type t = float = +struct + include Float + let max_val = max_float + let min_val = min_float + let rand = Random.float + let print i = Printf.printf "%f" i +end + +let float_elem = Number { ops = (module Float_elem) } + +module Float32_elem : Element_intf with type t = float32 = +struct + include Stdlib_stable.Float32 + let max_val = max_float + let min_val = min_float + let rand x = of_float (Random.float (to_float x)) + let print i = Printf.printf "%f" (to_float i) +end + +let float32_elem = Number { ops = (module Float32_elem) } + +let traverse0 (f : 'a. (module Element_intf with type t = 'a) -> 'a) = + let rec go : type a . a elem -> a = + fun (elem : a elem) -> + match elem with + | Number {ops} -> f ops + | Option elem -> Some (go elem) + | Tup2 (e1, e2) -> (go e1, go e2) + | Tup3 (e1, e2, e3) -> (go e1, go e2, go e3) + | Tup4 (e1, e2, e3, e4) -> (go e1, go e2, go e3, go e4) + | Tup5 (e1, e2, e3, e4, e5) -> (go e1, go e2, go e3, go e4, go e5) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + (go e1, go e2, go e3, go e4, go e5, go e6) + in + go + +let traverse1 (f : 'a. (module Element_intf with type t = 'a) -> 'a -> 'a) = + let rec go : type a . a elem -> a -> a = + fun (elem : a elem) (a : a) -> + match elem with + | Number {ops} -> f ops a + | Option elem -> Option.map (go elem) a + | Tup2 (e1, e2) -> + let a1, a2 = a in + (go e1 a1, go e2 a2) + | Tup3 (e1, e2, e3) -> + let a1, a2, a3 = a in + (go e1 a1, go e2 a2, go e3 a3) + | Tup4 (e1, e2, e3, e4) -> + let a1, a2, a3, a4 = a in + (go e1 a1, go e2 a2, go e3 a3, go e4 a4) + | Tup5 (e1, e2, e3, e4, e5) -> + let a1, a2, a3, a4, a5 = a in + (go e1 a1, go e2 a2, go e3 a3, go e4 a4, go e5 a5) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a1, a2, a3, a4, a5, a6 = a in + (go e1 a1, go e2 a2, go e3 a3, go e4 a4, go e5 a5, go e6 a6) + in + go + +let traverse2 + (f : 'a. (module Element_intf with type t = 'a) -> 'a -> 'a -> 'a) = + let rec go : type a . a elem -> a -> a -> a = + fun (elem : a elem) (a1 : a) (a2 : a) -> + match elem with + | Number {ops} -> f ops a1 a2 + | Option elem -> + begin match a1, a2 with + | None, _ | _, None -> None + | Some a1, Some a2 -> Some (go elem a1 a2) + end + | Tup2 (e1, e2) -> + let a11, a12 = a1 in + let a21, a22 = a2 in + (go e1 a11 a21, go e2 a12 a22) + | Tup3 (e1, e2, e3) -> + let a11, a12, a13 = a1 in + let a21, a22, a23 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23) + | Tup4 (e1, e2, e3, e4) -> + let a11, a12, a13, a14 = a1 in + let a21, a22, a23, a24 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24) + | Tup5 (e1, e2, e3, e4, e5) -> + let a11, a12, a13, a14, a15 = a1 in + let a21, a22, a23, a24, a25 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24, + go e5 a15 a25) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a11, a12, a13, a14, a15, a16 = a1 in + let a21, a22, a23, a24, a25, a26 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24, + go e5 a15 a25, go e6 a16 a26) + in + go + +let rec of_int : type a . a elem -> int -> a = + fun elem i -> + match elem with + | Number {ops} -> + let module O = (val ops) in + O.of_int i + | Option elem -> Some (of_int elem i) + | Tup2 (e1, e2) -> (of_int e1 i, of_int e2 i) + | Tup3 (e1, e2, e3) -> (of_int e1 i, of_int e2 i, of_int e3 i) + | Tup4 (e1, e2, e3, e4) -> + (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i) + | Tup5 (e1, e2, e3, e4, e5) -> + (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i, of_int e5 i) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i, of_int e5 i, + of_int e6 i) + +let add elem a1 a2 = + let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = + E.add a1 a2 + in + traverse2 f elem a1 a2 + +let sub elem a1 a2 = + let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = + E.sub a1 a2 + in + traverse2 f elem a1 a2 + +let mul elem a1 a2 = + let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = + E.mul a1 a2 + in + traverse2 f elem a1 a2 + +let neg elem a = + let f (type a) (module E : Element_intf with type t = a) (a : a) = + E.neg a + in + traverse1 f elem a + +let max_val elem = + let f (type a) (module E : Element_intf with type t = a) = + E.max_val + in + traverse0 f elem + +let min_val elem = + let rec go : type a . a elem -> a = + fun (elem : a elem) -> + match elem with + | Number {ops} -> + let module E = (val ops) in + E.min_val + | Option elem -> None + | Tup2 (e1, e2) -> (go e1, go e2) + | Tup3 (e1, e2, e3) -> (go e1, go e2, go e3) + | Tup4 (e1, e2, e3, e4) -> (go e1, go e2, go e3, go e4) + | Tup5 (e1, e2, e3, e4, e5) -> (go e1, go e2, go e3, go e4, go e5) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + (go e1, go e2, go e3, go e4, go e5, go e6) + in + go elem + +let rand elem a = + let f (type a) (module E : Element_intf with type t = a) (a : a) = + E.rand a + in + traverse1 f elem a + +let rec compare : type a . a elem -> a -> a -> int = + fun elem a1 a2 -> + match elem with + | Number {ops} -> + let module E = (val ops) in + E.compare a1 a2 + | Option elem -> Option.compare (compare elem) a1 a2 + | Tup2 (e1, e2) -> + let a11, a12 = a1 in + let a21, a22 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else compare e2 a12 a22 + | Tup3 (e1, e2, e3) -> + let a11, a12, a13 = a1 in + let a21, a22, a23 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else compare e3 a13 a23 + | Tup4 (e1, e2, e3, e4) -> + let a11, a12, a13, a14 = a1 in + let a21, a22, a23, a24 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else + let x = compare e3 a13 a23 in + if x <> 0 then x else compare e4 a14 a24 + | Tup5 (e1, e2, e3, e4, e5) -> + let a11, a12, a13, a14, a15 = a1 in + let a21, a22, a23, a24, a25 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else + let x = compare e3 a13 a23 in + if x <> 0 then x else + let x = compare e4 a14 a24 in + if x <> 0 then x else compare e5 a15 a25 + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a11, a12, a13, a14, a15, a16 = a1 in + let a21, a22, a23, a24, a25, a26 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else + let x = compare e3 a13 a23 in + if x <> 0 then x else + let x = compare e4 a14 a24 in + if x <> 0 then x else + let x = compare e5 a15 a25 in + if x <> 0 then x else + compare e6 a16 a26 + +let rec print : type a . a elem -> a -> unit = + let open struct + type packed = P : 'a elem * 'a -> packed + + let print_comma_sep l = + Printf.printf "("; + let rec go l = + match l with + | [] -> assert false + | [P (e,a)] -> + print e a; + Printf.printf ")" + | (P (e,a)) :: l -> + print e a; + Printf.printf ", "; + go l + in + go l + end + in + fun elem a -> + match elem with + | Number {ops} -> + let module E = (val ops) in + E.print a + | Option elem -> + begin match a with + | None -> Printf.printf "None" + | Some a -> begin + Printf.printf "Some "; + print elem a + end + end + | Tup2 (e1, e2) -> + let a1, a2 = a in + print_comma_sep [P (e1, a1); P (e2, a2)] + | Tup3 (e1, e2, e3) -> + let a1, a2, a3 = a in + print_comma_sep [P (e1, a1); P (e2, a2); P (e3, a3)] + | Tup4 (e1, e2, e3, e4) -> + let a1, a2, a3, a4 = a in + print_comma_sep [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4)] + | Tup5 (e1, e2, e3, e4, e5) -> + let a1, a2, a3, a4, a5 = a in + print_comma_sep + [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4); P (e5, a5)] + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a1, a2, a3, a4, a5, a6 = a in + print_comma_sep + [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4); P (e5, a5); + P (e6, a6)] + +let make_element_ops (type a) (elem : a elem) + : (module Element_intf with type t = a) = + (module struct + type t = a + + let of_int i = of_int elem i + let add t1 t2 = add elem t1 t2 + let sub t1 t2 = sub elem t1 t2 + let mul t1 t2 = mul elem t1 t2 + let neg t = neg elem t + let max_val = max_val elem + let min_val = min_val elem + let rand t = rand elem t + let compare t1 t2 = compare elem t1 t2 + let print t = print elem t + end) diff --git a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli new file mode 100644 index 00000000000..2ba44fb0ad1 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli @@ -0,0 +1,26 @@ +(* This module defines some helpers for writing tests on arays of unboxed + products. See [README.md] in this directory. *) + +module type Element_intf = Test_gen_u_array.Element_intf + +type 'a elem = + | Number : { ops : (module Element_intf with type t = 'a) } -> 'a elem + | Option : 'a elem -> ('a option) elem + | Tup2 : 'a1 elem * 'a2 elem -> ('a1 * 'a2) elem + | Tup3 : 'a1 elem * 'a2 elem * 'a3 elem -> ('a1 * 'a2 * 'a3) elem + | Tup4 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem + -> ('a1 * 'a2 * 'a3 * 'a4) elem + | Tup5 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) elem + | Tup6 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem * 'a6 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) elem + +val int_elem : int elem +val int32_elem : int32 elem +val int64_elem : int64 elem +val nativeint_elem : nativeint elem + +val float_elem : float elem +val float32_elem : float32 elem + +val make_element_ops : 'a elem -> (module Element_intf with type t = 'a) diff --git a/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml b/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml new file mode 100644 index 00000000000..2fb1aaa1827 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml @@ -0,0 +1,682 @@ +(* This file is used in [run_makearray_dynamic_tests.ml]. *) +open Stdlib_upstream_compatible +open Stdlib_stable +module List = ListLabels +module String = StringLabels + +let failwithf fmt = Printf.ksprintf failwith fmt +let sprintf = Printf.sprintf + +(* See [test_makearray_dynamic] for the main testing steps! *) + +module Ty : sig + (* A type in the generated code *) + type t = { + ty_code : string; + (* Code for this type expression (e.g. "int option * float") *) + value_code : int -> string; + (* Given some integer seed, generate code for a value of this type. + E.g. passing 3 gives "(Some 3, 3.)" for [int option * float]. *) + mk_value_code : string; + (* Code that dynamically implements [value_code], creating a value from an + integer seed bound to "i". + We should be able to generate this code: + "let mk_value (i : int) : $ty_code = $mk_value_code" *) + eq : string; + (* A function that implements equality in the generated code. + We should be able generate this code: + "let eq : $ty_code @ local -> $ty_code @ local -> bool = $eq" *) + is_gc_ignorable : bool; + (* Whether type only contains non-values/immediates (this used to gate + blit tests, but now that blits work for all types, this field is + unused). *) + } + + (* Generate typedecls for user-defined nominal types that have been created *) + val decls_code : unit -> string list + + (* Takes the record name and (label_name, label_type) pairs *) + val unboxed_record : string -> (string * t) list -> t + + (* [enum 3] represents [type enum3 = A3_0 | A3_1 | A3_2]. *) + val enum : int -> t + + (* Structural and built-in types *) + + val option : t -> t + val tuple : t list -> t + val unboxed_tuple : t list -> t + + val int : t + val float : t + val float_u : t + val float32 : t + val float32_u : t + val int32 : t + val int32_u : t + val int64 : t + val int64_u : t + val nativeint : t + val nativeint_u : t +end = struct + type t = { + ty_code : string; + value_code : int -> string; + mk_value_code : string; + eq : string; + is_gc_ignorable : bool; + } + + let ty_code t = t.ty_code + let value_code t = t.value_code + let mk_value_code t = t.mk_value_code + let is_gc_ignorable t = t.is_gc_ignorable + + let map_value_code ts i = List.map ts ~f:(fun t -> t.value_code i) + + (* If (name, decl) is in this list, we'll generate "type $name = $decl" *) + let decls : (string * string) list ref = ref [] + + let decls_code () = + (* [!decls] is only reversed for aesthetic reasons. *) + List.mapi (List.rev !decls) ~f:(fun i (name, def) -> + (if i == 0 then "type " else "and ") ^ name ^ " = " ^ def + ) + + let add_decl ~name ~def = + match List.assoc_opt name !decls with + | Some def' -> + if not (String.equal def def') then + failwithf + "%s has conflicting definitions:\n %s\nand\n %s" name def' def + | None -> decls := (name, def) :: !decls + + let unboxed_record name labeled_ts = + let lbls, ts = List.split labeled_ts in + let assemble colon_or_eq fields = + let labeled_fields = + List.map2 lbls fields ~f:(fun s x -> s ^ " " ^ colon_or_eq ^ " " ^ x) + in + "#{ " ^ String.concat ~sep:"; " labeled_fields ^ " }" + in + let assemble_expr fields = "(" ^ assemble "=" fields ^ " : " ^ name ^ ")" in + let value_code i = assemble_expr (map_value_code ts i) in + let mk_value_code = assemble_expr (List.map ts ~f:mk_value_code) in + let pat i = + assemble_expr (List.map lbls ~f:(fun s -> s ^ Int.to_string i)) + in + let eq = + let body = + List.map labeled_ts ~f:(fun (s, t) -> sprintf "%s %s1 %s2" t.eq s s) + |> String.concat ~sep:" && " + in + sprintf "(fun %s %s -> %s)" (pat 1) (pat 2) body + in + add_decl ~name ~def:(assemble ":" (List.map ts ~f:ty_code)); + { + ty_code = name; + value_code; + mk_value_code; + eq; + is_gc_ignorable = List.for_all ~f:is_gc_ignorable ts; + } + + let enum size = + let ith_ctor i = sprintf "A%d_%d" size i in + let def = List.init ~len:size ~f:ith_ctor |> String.concat ~sep:" | " in + let eq = + let eq_pat = + List.init ~len:size ~f:(fun i -> ith_ctor i ^ ", " ^ ith_ctor i) + |> String.concat ~sep:" | " + in + sprintf "(fun a b -> match a, b with %s -> true | _ -> false)" eq_pat + in + let mk_value_code = + let brs = + List.init ~len:size ~f:(fun i -> sprintf "%d -> %s" i (ith_ctor i)) + @ ["_ -> assert false"] + in + sprintf "(match Int.rem i %d with %s)" size (String.concat ~sep:" | " brs) + in + let name = sprintf "enum%d" size in + add_decl ~name ~def; + { + ty_code = name; + value_code = (fun i -> ith_ctor (Int.rem i size)); + mk_value_code; + eq; + is_gc_ignorable = true; + } + + let option t = { + ty_code = t.ty_code ^ " option"; + value_code = + (fun i -> if i == 0 then "None" else "Some " ^ t.value_code i); + mk_value_code = + "(if i == 0 then None else Some (" ^ t.mk_value_code ^ "))"; + eq = "(fun a b -> match a, b with None,None -> true | Some a,Some b -> " + ^ t.eq ^ " a b|_->false)"; + is_gc_ignorable = false; + } + + let gen_tuple ~unboxed ts = + let hash = if unboxed then "#" else "" in + let assemble ~sep xs = sprintf "%s(%s)" hash (String.concat ~sep xs) in + let value_code i = assemble ~sep:", " (map_value_code ts i) in + let mk_value_code = assemble ~sep:", " (List.map ts ~f:mk_value_code) in + let eq = + let pat s = + assemble ~sep:", " (List.mapi ts ~f:(fun i _ -> s ^ Int.to_string i)) + in + let body = + List.mapi ts ~f:(fun i t -> sprintf "%s a%d b%d" t.eq i i) + |> String.concat ~sep:" && " + in + sprintf "(fun %s %s -> %s)" (pat "a") (pat "b") body + in + { + ty_code = assemble ~sep:" * " (List.map ts ~f:ty_code); + value_code; + mk_value_code; + eq; + is_gc_ignorable = unboxed && List.for_all ~f:is_gc_ignorable ts; + } + + let tuple = gen_tuple ~unboxed:false + + let unboxed_tuple = gen_tuple ~unboxed:true + + let int = { + ty_code = "int"; + value_code = Int.to_string; + mk_value_code = "i"; + eq = "(fun a b -> Int.equal a b)"; + is_gc_ignorable = true; + } + + let float = { + ty_code = "float"; + value_code = (fun i -> Int.to_string i ^ "."); + mk_value_code = "Float.of_int i"; + eq = "(fun a b -> Float.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let float_u = { + ty_code = "float#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "."); + mk_value_code = "Float_u.of_int i"; + eq = "(fun a b -> Float_u.(equal (add #0. a) (add #0. b)))"; + is_gc_ignorable = true; + } + + let float32 = { + ty_code = "float32"; + value_code = (fun i -> Int.to_string i ^ ".s"); + mk_value_code = "Float32.of_int i"; + eq = "(fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b))"; + is_gc_ignorable = false; + } + + let float32_u = { + ty_code = "float32#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ ".s"); + mk_value_code = "Float32_u.of_int i"; + eq = "(fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b)))"; + is_gc_ignorable = true; + } + + let int32 = { + ty_code = "int32"; + value_code = (fun i -> Int.to_string i ^ "l"); + mk_value_code = "Int32.of_int i"; + eq = "(fun a b -> Int32.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let int32_u = { + ty_code = "int32#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "l"); + mk_value_code = "Int32_u.of_int i"; + eq = "(fun a b -> Int32_u.(equal (add #0l a) (add #0l b)))"; + is_gc_ignorable = true; + } + + let int64 = { + ty_code = "int64"; + value_code = (fun i -> Int.to_string i ^ "L"); + mk_value_code = "Int64.of_int i"; + eq = "(fun a b -> Int64.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let int64_u = { + ty_code = "int64#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "L"); + mk_value_code = "Int64_u.of_int i"; + eq = "(fun a b -> Int64_u.(equal (add #0L a) (add #0L b)))"; + is_gc_ignorable = true; + } + + let nativeint = { + ty_code = "nativeint"; + value_code = (fun i -> (Int.to_string i) ^ "n"); + mk_value_code = "Nativeint.of_int i"; + eq = "(fun a b -> Nativeint.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let nativeint_u = { + ty_code = "nativeint#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "n"); + mk_value_code = "Nativeint_u.of_int i"; + eq = "(fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b)))"; + is_gc_ignorable = true; + } +end + +let ty_ur1 = Ty.(unboxed_record "ur1" ["a", int64_u; "b", float_u]) +let ty_ur2 = Ty.(unboxed_record "ur2" ["a", int64_u; "b", int]) +let ty_ur3 = Ty.(unboxed_record "ur3" ["a", int64_u]) +let ty_ur4 = Ty.(unboxed_record "ur4" ["a", ty_ur1; "b", ty_ur3]) + +(* Types the GC always ignores, which can be used with %makearray_dynamic_uninit *) +let always_ignored_types = Ty.([ + float32_u; float_u; int32_u; int64_u; nativeint_u; ty_ur1; ty_ur3; ty_ur4; + unboxed_tuple [float_u; int32_u; int64_u]; + unboxed_tuple [ + float_u; + unboxed_tuple [int64_u; int64_u]; + float32_u; + unboxed_tuple [int32_u; unboxed_tuple [float32_u; float_u]]; + int64_u; + ]; + unboxed_tuple [int64_u; ty_ur1]; +]) + +let types = always_ignored_types @ Ty.([ + float32; float; int32; int64; nativeint; int; enum 3; ty_ur2; + unboxed_tuple [int; int64]; + unboxed_tuple [ + option int64; + unboxed_tuple [int; int32; float]; + float; + unboxed_tuple [float32; option (tuple [nativeint; nativeint])]; + int32 + ]; + unboxed_tuple [float; float; float]; + unboxed_tuple [ + float; + unboxed_tuple [float; float]; + unboxed_tuple [float; unboxed_tuple [float; float; float]] + ]; + unboxed_tuple [float_u; int; int64_u]; + unboxed_tuple [ + float_u; + unboxed_tuple [int; int64_u]; + float32_u; + unboxed_tuple [int32_u; unboxed_tuple [float32_u; float_u]]; + int; + ]; + unboxed_tuple [ty_ur2; ty_ur1]; +]) + +let preamble = {| +open Stdlib_upstream_compatible +open Stdlib_stable +module List = ListLabels +module String = StringLabels + +external[@layout_poly] makearray_dynamic_uninit_local : + ('a : any_non_null) . int -> 'a array @ local = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_uninit : + ('a : any_non_null) . int -> 'a array = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_local : + ('a : any_non_null) . int -> 'a -> 'a array @ local = + "%makearray_dynamic" + +external[@layout_poly] makearray_dynamic : + ('a : any_non_null) . int -> 'a -> 'a array = + "%makearray_dynamic" + +external[@layout_poly] get : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = + "%array_safe_get" + +external[@layout_poly] set : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = + "%array_safe_set" + +external[@layout_poly] unsafe_blit : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> ('a array[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = + "%arrayblit" + +let failwithf fmt = Printf.ksprintf failwith fmt + +external globalize : local_ 'a -> 'a = "%obj_dup";; + +(* Redefine iter to infer locality *) +let rec iter ~f = function + [] -> () + | a::l -> f a; iter ~f l + +let tests_run = ref [] + +let mark_test_run test_id = + if not (List.mem ~set:!tests_run test_id) then + tests_run := test_id :: !tests_run + +(* Various interesting values *) + +let sizes = [ 0; 1; 2; 30; 31; 32 ] + +let bad_indices size = + [ -100; -2; -1; size; size + 1; size + 100; Int.min_int; Int.max_int ] + +let blit_offsets size = + let candidates = [ 0; 1; size / 3; size / 2; size - 1; size ] in + List.filter candidates ~f:(fun ofs -> ofs > 0 && ofs < size) + |> List.sort_uniq ~cmp:Int.compare + +let blit_lens ~ofs1 ~ofs2 ~size1 ~size2 = + let len_until_end = Int.min (size1 - ofs1) (size2 - ofs2) in + let candidates = [ 0; 1; size1 / 2; len_until_end - 1; len_until_end ] in + List.filter candidates ~f:(fun len -> ofs1 + len <= size1 && ofs2 + len <= size2) + |> List.sort_uniq ~cmp:Int.compare +|} + +let indent = ref 0 + +let with_indent f = incr indent; f (); decr indent + +let line fmt = + Printf.ksprintf + (fun s -> + let indent = Seq.init (!indent * 2) (fun _ -> ' ') |> String.of_seq in + print_endline (indent ^ s); + flush stdout) + fmt + +let print_in_test s = + line {|let () = Printf.printf "%s%%!\n";;|} (String.escaped s) + +let seq_print_in_test s = + line {|print_endline "%s%!";|} (String.escaped s) + +let makearray_dynamic_fn ~uninit ~local = + let uninit_s = if uninit then "_uninit" else "" in + let local_s = if local then "_local" else "" in + "makearray_dynamic" ^ uninit_s ^ local_s + +type debug_expr = { expr : string ; format_s : string } + +let concat_with_leading_spaces l = + List.map l ~f:(fun s -> " " ^ s) + |> String.concat ~sep:"" + +let combine_debug_exprs (l : debug_expr list) : debug_expr = + let debug_expr_to_tuple { expr ; format_s } = expr, format_s in + let exprs, format_ss = List.split (List.rev_map ~f:debug_expr_to_tuple l) in + let expr = concat_with_leading_spaces exprs in + let format_s = concat_with_leading_spaces format_ss in + { expr; format_s } + +let seq_print_debug_exprs ~debug_exprs = + let { expr ; format_s } = combine_debug_exprs debug_exprs in + line {|Printf.printf "%s: %s\n%%!"%s;|} expr format_s expr + +let test_id = ref 0 + +let seq_assert ~debug_exprs s = + incr test_id; + let { expr ; format_s } = combine_debug_exprs debug_exprs in + line "mark_test_run %d;" !test_id; + line "let test = %s in" s; + line {|if not test then failwithf "test %d failed%s"%s;|} + !test_id format_s expr + +let for_ var ~from ~to_ ~debug_exprs f = + line "for %s = %s to %s do" var from to_; + with_indent (fun () -> + let debug_exprs = { expr = var; format_s = "%d" } :: debug_exprs in + f ~debug_exprs + ); + line "done;" + +let for_i_below_size = for_ "i" ~from:"0" ~to_:"size - 1" + +(* Iterate through a list of ints *) +let iter l var ~debug_exprs f = + line "iter (%s) ~f:(fun %s ->" l var; + with_indent (fun () -> + let debug_exprs = { expr = var; format_s = "%d" } :: debug_exprs in + f ~debug_exprs + ); + line ") [@nontail];" + +let section s = + let s_as_stars = String.init (String.length s) ~f:(fun _ -> '*') in + line "(**%s**)" s_as_stars; + line "(* %s *)" s; + line "(**%s**)" s_as_stars + +(* Test steps: + 1. Create an array, possibly local, possibly uninitialized + 2. For initialized arrays, check all elements have the correct value + 3. Fill array with distinct values and read back those values + 4. Check that getting bad indices errors + 5. Check that setting bad indices errors + 6. Check that array contents were unaffected by setting bad indices + 7. Overlapping blits + 8. Blits to heap arrays + 9. Blits to local arrays +*) +let test_makearray_dynamic ~uninit ~local ty = + let makearray_dynamic = makearray_dynamic_fn ~uninit ~local in + let debug_exprs = [{ expr = "size"; format_s = "%d"}] in + let ty_array_s = ty.Ty.ty_code ^ " array" in + (* seq_print_in_test ty.Ty.ty_code; *) + section (" " ^ ty.Ty.ty_code ^ " "); + line "let eq = %s in" ty.Ty.eq; + line "let mk_value i = %s in" ty.Ty.mk_value_code; + line "(* 1. Create an array of size [size] *)"; + (if uninit then ( + line "let a : %s = %s size in" ty_array_s makearray_dynamic; + line "(* 2. For uninitialized arrays, element values are unspecified *)" + ) else + line "let a : %s = %s size %s in" ty_array_s makearray_dynamic (ty.Ty.value_code 0); + line "(* 2. For initialized arrays, check all elements have the correct value *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "let el = get a i in"; + if uninit then + line "let _ = el in ()" + else ( + let test = sprintf "eq el %s" (ty.Ty.value_code 0) in + seq_assert ~debug_exprs test; + ) + )); + line "(* 3. Fill [a] with distinct values and read back those values *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "set a i (mk_value i);" + ); + line "Gc.compact ();"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + seq_assert ~debug_exprs "eq (get a i) (mk_value i)" + ); + iter "bad_indices size" "i" ~debug_exprs (fun ~debug_exprs -> + line "(* 4. Getting bad indices errors *)"; + line "let raises ="; + with_indent (fun () -> + line "match get a i with"; + line "| exception Invalid_argument _ -> true"; + line "| _ -> false" + ); + line "in"; + seq_assert ~debug_exprs "raises"; + line "(* 5. Setting bad indices errors *)"; + line "let raises ="; + with_indent (fun () -> + line "match set a i %s with" (ty.Ty.value_code 0); + line "| exception Invalid_argument _ -> true"; + line "| _ -> false" + ); + line "in"; + seq_assert ~debug_exprs "raises" + ); + line "Gc.compact ();"; + line "(* 6. Array contents were unaffacted by setting bad indices *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + seq_assert ~debug_exprs "eq (get a i) (mk_value i)" + ); + (* Blits currently only work for GC ignorable values *) + line "(* 7. Overlapping blits *)"; + iter "blit_offsets size" "ofs1" ~debug_exprs (fun ~debug_exprs -> + iter "blit_offsets size" "ofs2" ~debug_exprs (fun ~debug_exprs -> + let lens = "blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size" in + iter lens "len" ~debug_exprs (fun ~debug_exprs -> + line "unsafe_blit a ofs1 a ofs2 len;"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "let expected_src_i ="; + with_indent (fun () -> + line "if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i" + ); + line "in"; + seq_assert ~debug_exprs "eq (get a i) (mk_value expected_src_i)" + ); + line "(* Reset array *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "set a i (mk_value i);" + ) + ); + ); + ); + line "Gc.compact ();"; + let test_blit_to ~to_local = + iter "sizes" "size2" ~debug_exprs (fun ~debug_exprs -> + iter "blit_offsets size" "ofs1" ~debug_exprs (fun ~debug_exprs -> + iter "blit_offsets size2" "ofs2" ~debug_exprs (fun ~debug_exprs -> + let lens = "blit_lens ~ofs1 ~ofs2 ~size1:size ~size2" in + iter lens "len" ~debug_exprs (fun ~debug_exprs -> + (if to_local then + line "let local_ a2 = makearray_dynamic_local size2 %s in" (ty.Ty.value_code 0) + else + line "let a2 = makearray_dynamic size2 %s in" (ty.Ty.value_code 0)); + line "unsafe_blit a ofs1 a2 ofs2 len;"; + for_ "i" ~from:"0" ~to_:"size2 - 1" ~debug_exprs (fun ~debug_exprs -> + line "let expected_src_i ="; + with_indent (fun () -> + line "if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0" + ); + line "in"; + seq_assert ~debug_exprs "eq (get a2 i) (mk_value expected_src_i)" + ) + ) + ) + ) + ); + line "Gc.compact ();" + in + line "(* 8. Blits to heap arrays *)"; + test_blit_to ~to_local:false; + line "(* 9. Blits to local arrays *)"; + test_blit_to ~to_local:true; + print_endline "" + +let toplevel_unit_block f = + assert (Int.equal !indent 0); + line "let () ="; + with_indent (fun () -> + f (); line "()" + ); + line ";;"; + line "" + +let main ~bytecode = + let debug_exprs = [] in + line {|(* TEST + include stdlib_stable; + include stdlib_upstream_compatible;|}; + if bytecode then ( + line {| flags = "-extension layouts_beta";|}; + (* CR layouts: enable for arm64 once float32 is available *) + line {| arch_amd64;|}; + line {| bytecode;|}; + ) else ( + line {| modules = "stubs.c";|}; + line {| flags = "-extension layouts_beta -extension simd_beta";|}; + line {| flambda2;|}; + line {| stack-allocation;|}; + line {| arch_amd64;|}; + line {| native;|}; + ); + line {|*)|}; + line "(** This is code generated by [generate_makearray_dynamic_tests.ml]. *)"; + line ""; + line "%s" preamble; + List.iter (Ty.decls_code ()) ~f:(fun s -> line "%s" s); + line ""; + line "(* Catch metaprogramming errors early *)"; + toplevel_unit_block (fun () -> + let open Ty in + line "(* Check types and constants *)"; + List.iter types ~f:(fun ty -> + line "let _ : %s = %s in" ty.ty_code (ty.value_code 0) + ); + line "(* Check equality and mk_value functions *)"; + List.iter types ~f:(fun ty -> + line "let eq : %s @ local -> %s @ local -> bool = %s in" + ty.ty_code ty.ty_code ty.eq; + line "let mk_value i = %s in" ty.mk_value_code; + seq_assert ~debug_exprs + (sprintf "eq (mk_value 1) %s" (ty.value_code 1)); + seq_assert ~debug_exprs + (sprintf "eq %s %s" (ty.value_code 1) (ty.value_code 1)); + seq_assert ~debug_exprs + (sprintf "not (eq %s %s)" (ty.value_code 1) (ty.value_code 2)) + ); + line "(* Check always-GC-ignored types *)"; + List.iter always_ignored_types ~f:(fun ty -> + line "let _ = (makearray_dynamic_uninit 1 : %s array) in" (ty.ty_code) + ); + ); + List.iter [false; true] ~f:(fun uninit -> + List.iter [false; true] ~f:(fun local -> + line "let test_%s size =" (makearray_dynamic_fn ~uninit ~local); + with_indent (fun () -> + let tys = if uninit then always_ignored_types else types in + List.iter tys ~f:(test_makearray_dynamic ~uninit ~local); + line "()"; + ); + line ""; + ) + ); + line "(* Main tests *)"; + toplevel_unit_block (fun () -> + List.iter [false; true] ~f:(fun uninit -> + List.iter [false; true] ~f:(fun local -> + let test_fn = "test_" ^ makearray_dynamic_fn ~uninit ~local in + seq_print_in_test test_fn; + line "iter sizes ~f:%s;" test_fn + ) + ) + ); + line "for i = 1 to %d do" !test_id; + with_indent (fun () -> + line + {|if not (List.mem ~set:!tests_run i) then failwithf "test %%d not run" i|} + ); + line "done;;"; + print_in_test "All tests passed." + +let () = + let bytecode = + match Sys.argv with + | [| _; "native" |] -> false + | [| _; "byte" |] -> true + | _ -> failwith (sprintf "Usage %s " Sys.argv.(0)) + in + main ~bytecode diff --git a/testsuite/tests/typing-layouts-arrays/generated_test.ml b/testsuite/tests/typing-layouts-arrays/generated_test.ml new file mode 100644 index 00000000000..873b18854ae --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/generated_test.ml @@ -0,0 +1,8785 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + modules = "stubs.c"; + flags = "-extension layouts_beta -extension simd_beta"; + flambda2; + stack-allocation; + arch_amd64; + native; +*) +(** This is code generated by [generate_makearray_dynamic_tests.ml]. *) + + +open Stdlib_upstream_compatible +open Stdlib_stable +module List = ListLabels +module String = StringLabels + +external[@layout_poly] makearray_dynamic_uninit_local : + ('a : any_non_null) . int -> 'a array @ local = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_uninit : + ('a : any_non_null) . int -> 'a array = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_local : + ('a : any_non_null) . int -> 'a -> 'a array @ local = + "%makearray_dynamic" + +external[@layout_poly] makearray_dynamic : + ('a : any_non_null) . int -> 'a -> 'a array = + "%makearray_dynamic" + +external[@layout_poly] get : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = + "%array_safe_get" + +external[@layout_poly] set : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = + "%array_safe_set" + +external[@layout_poly] unsafe_blit : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> ('a array[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = + "%arrayblit" + +let failwithf fmt = Printf.ksprintf failwith fmt + +external globalize : local_ 'a -> 'a = "%obj_dup";; + +(* Redefine iter to infer locality *) +let rec iter ~f = function + [] -> () + | a::l -> f a; iter ~f l + +let tests_run = ref [] + +let mark_test_run test_id = + if not (List.mem ~set:!tests_run test_id) then + tests_run := test_id :: !tests_run + +(* Various interesting values *) + +let sizes = [ 0; 1; 2; 30; 31; 32 ] + +let bad_indices size = + [ -100; -2; -1; size; size + 1; size + 100; Int.min_int; Int.max_int ] + +let blit_offsets size = + let candidates = [ 0; 1; size / 3; size / 2; size - 1; size ] in + List.filter candidates ~f:(fun ofs -> ofs > 0 && ofs < size) + |> List.sort_uniq ~cmp:Int.compare + +let blit_lens ~ofs1 ~ofs2 ~size1 ~size2 = + let len_until_end = Int.min (size1 - ofs1) (size2 - ofs2) in + let candidates = [ 0; 1; size1 / 2; len_until_end - 1; len_until_end ] in + List.filter candidates ~f:(fun len -> ofs1 + len <= size1 && ofs2 + len <= size2) + |> List.sort_uniq ~cmp:Int.compare + +type ur1 = #{ a : int64#; b : float# } +and ur2 = #{ a : int64#; b : int } +and ur3 = #{ a : int64# } +and ur4 = #{ a : ur1; b : ur3 } +and enum3 = A3_0 | A3_1 | A3_2 + +(* Catch metaprogramming errors early *) +let () = + (* Check types and constants *) + let _ : float32# = #0.s in + let _ : float# = #0. in + let _ : int32# = #0l in + let _ : int64# = #0L in + let _ : nativeint# = #0n in + let _ : ur1 = (#{ a = #0L; b = #0. } : ur1) in + let _ : ur3 = (#{ a = #0L } : ur3) in + let _ : ur4 = (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + let _ : #(float# * int32# * int64#) = #(#0., #0l, #0L) in + let _ : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) = #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + let _ : #(int64# * ur1) = #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + let _ : float32 = 0.s in + let _ : float = 0. in + let _ : int32 = 0l in + let _ : int64 = 0L in + let _ : nativeint = 0n in + let _ : int = 0 in + let _ : enum3 = A3_0 in + let _ : ur2 = (#{ a = #0L; b = 0 } : ur2) in + let _ : #(int * int64) = #(0, 0L) in + let _ : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) = #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + let _ : #(float * float * float) = #(0., 0., 0.) in + let _ : #(float * #(float * float) * #(float * #(float * float * float))) = #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + let _ : #(float# * int * int64#) = #(#0., 0, #0L) in + let _ : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) = #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + let _ : #(ur2 * ur1) = #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + (* Check equality and mk_value functions *) + let eq : float32# @ local -> float32# @ local -> bool = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + mark_test_run 1; + let test = eq (mk_value 1) #1.s in + if not test then failwithf "test 1 failed"; + mark_test_run 2; + let test = eq #1.s #1.s in + if not test then failwithf "test 2 failed"; + mark_test_run 3; + let test = not (eq #1.s #2.s) in + if not test then failwithf "test 3 failed"; + let eq : float# @ local -> float# @ local -> bool = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + mark_test_run 4; + let test = eq (mk_value 1) #1. in + if not test then failwithf "test 4 failed"; + mark_test_run 5; + let test = eq #1. #1. in + if not test then failwithf "test 5 failed"; + mark_test_run 6; + let test = not (eq #1. #2.) in + if not test then failwithf "test 6 failed"; + let eq : int32# @ local -> int32# @ local -> bool = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + mark_test_run 7; + let test = eq (mk_value 1) #1l in + if not test then failwithf "test 7 failed"; + mark_test_run 8; + let test = eq #1l #1l in + if not test then failwithf "test 8 failed"; + mark_test_run 9; + let test = not (eq #1l #2l) in + if not test then failwithf "test 9 failed"; + let eq : int64# @ local -> int64# @ local -> bool = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + mark_test_run 10; + let test = eq (mk_value 1) #1L in + if not test then failwithf "test 10 failed"; + mark_test_run 11; + let test = eq #1L #1L in + if not test then failwithf "test 11 failed"; + mark_test_run 12; + let test = not (eq #1L #2L) in + if not test then failwithf "test 12 failed"; + let eq : nativeint# @ local -> nativeint# @ local -> bool = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + mark_test_run 13; + let test = eq (mk_value 1) #1n in + if not test then failwithf "test 13 failed"; + mark_test_run 14; + let test = eq #1n #1n in + if not test then failwithf "test 14 failed"; + mark_test_run 15; + let test = not (eq #1n #2n) in + if not test then failwithf "test 15 failed"; + let eq : ur1 @ local -> ur1 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + mark_test_run 16; + let test = eq (mk_value 1) (#{ a = #1L; b = #1. } : ur1) in + if not test then failwithf "test 16 failed"; + mark_test_run 17; + let test = eq (#{ a = #1L; b = #1. } : ur1) (#{ a = #1L; b = #1. } : ur1) in + if not test then failwithf "test 17 failed"; + mark_test_run 18; + let test = not (eq (#{ a = #1L; b = #1. } : ur1) (#{ a = #2L; b = #2. } : ur1)) in + if not test then failwithf "test 18 failed"; + let eq : ur3 @ local -> ur3 @ local -> bool = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + mark_test_run 19; + let test = eq (mk_value 1) (#{ a = #1L } : ur3) in + if not test then failwithf "test 19 failed"; + mark_test_run 20; + let test = eq (#{ a = #1L } : ur3) (#{ a = #1L } : ur3) in + if not test then failwithf "test 20 failed"; + mark_test_run 21; + let test = not (eq (#{ a = #1L } : ur3) (#{ a = #2L } : ur3)) in + if not test then failwithf "test 21 failed"; + let eq : ur4 @ local -> ur4 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + mark_test_run 22; + let test = eq (mk_value 1) (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) in + if not test then failwithf "test 22 failed"; + mark_test_run 23; + let test = eq (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) in + if not test then failwithf "test 23 failed"; + mark_test_run 24; + let test = not (eq (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) (#{ a = (#{ a = #2L; b = #2. } : ur1); b = (#{ a = #2L } : ur3) } : ur4)) in + if not test then failwithf "test 24 failed"; + let eq : #(float# * int32# * int64#) @ local -> #(float# * int32# * int64#) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + mark_test_run 25; + let test = eq (mk_value 1) #(#1., #1l, #1L) in + if not test then failwithf "test 25 failed"; + mark_test_run 26; + let test = eq #(#1., #1l, #1L) #(#1., #1l, #1L) in + if not test then failwithf "test 26 failed"; + mark_test_run 27; + let test = not (eq #(#1., #1l, #1L) #(#2., #2l, #2L)) in + if not test then failwithf "test 27 failed"; + let eq : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) @ local -> #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + mark_test_run 28; + let test = eq (mk_value 1) #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) in + if not test then failwithf "test 28 failed"; + mark_test_run 29; + let test = eq #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) in + if not test then failwithf "test 29 failed"; + mark_test_run 30; + let test = not (eq #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) #(#2., #(#2L, #2L), #2.s, #(#2l, #(#2.s, #2.)), #2L)) in + if not test then failwithf "test 30 failed"; + let eq : #(int64# * ur1) @ local -> #(int64# * ur1) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + mark_test_run 31; + let test = eq (mk_value 1) #(#1L, (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 31 failed"; + mark_test_run 32; + let test = eq #(#1L, (#{ a = #1L; b = #1. } : ur1)) #(#1L, (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 32 failed"; + mark_test_run 33; + let test = not (eq #(#1L, (#{ a = #1L; b = #1. } : ur1)) #(#2L, (#{ a = #2L; b = #2. } : ur1))) in + if not test then failwithf "test 33 failed"; + let eq : float32 @ local -> float32 @ local -> bool = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in + let mk_value i = Float32.of_int i in + mark_test_run 34; + let test = eq (mk_value 1) 1.s in + if not test then failwithf "test 34 failed"; + mark_test_run 35; + let test = eq 1.s 1.s in + if not test then failwithf "test 35 failed"; + mark_test_run 36; + let test = not (eq 1.s 2.s) in + if not test then failwithf "test 36 failed"; + let eq : float @ local -> float @ local -> bool = (fun a b -> Float.equal (globalize a) (globalize b)) in + let mk_value i = Float.of_int i in + mark_test_run 37; + let test = eq (mk_value 1) 1. in + if not test then failwithf "test 37 failed"; + mark_test_run 38; + let test = eq 1. 1. in + if not test then failwithf "test 38 failed"; + mark_test_run 39; + let test = not (eq 1. 2.) in + if not test then failwithf "test 39 failed"; + let eq : int32 @ local -> int32 @ local -> bool = (fun a b -> Int32.equal (globalize a) (globalize b)) in + let mk_value i = Int32.of_int i in + mark_test_run 40; + let test = eq (mk_value 1) 1l in + if not test then failwithf "test 40 failed"; + mark_test_run 41; + let test = eq 1l 1l in + if not test then failwithf "test 41 failed"; + mark_test_run 42; + let test = not (eq 1l 2l) in + if not test then failwithf "test 42 failed"; + let eq : int64 @ local -> int64 @ local -> bool = (fun a b -> Int64.equal (globalize a) (globalize b)) in + let mk_value i = Int64.of_int i in + mark_test_run 43; + let test = eq (mk_value 1) 1L in + if not test then failwithf "test 43 failed"; + mark_test_run 44; + let test = eq 1L 1L in + if not test then failwithf "test 44 failed"; + mark_test_run 45; + let test = not (eq 1L 2L) in + if not test then failwithf "test 45 failed"; + let eq : nativeint @ local -> nativeint @ local -> bool = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in + let mk_value i = Nativeint.of_int i in + mark_test_run 46; + let test = eq (mk_value 1) 1n in + if not test then failwithf "test 46 failed"; + mark_test_run 47; + let test = eq 1n 1n in + if not test then failwithf "test 47 failed"; + mark_test_run 48; + let test = not (eq 1n 2n) in + if not test then failwithf "test 48 failed"; + let eq : int @ local -> int @ local -> bool = (fun a b -> Int.equal a b) in + let mk_value i = i in + mark_test_run 49; + let test = eq (mk_value 1) 1 in + if not test then failwithf "test 49 failed"; + mark_test_run 50; + let test = eq 1 1 in + if not test then failwithf "test 50 failed"; + mark_test_run 51; + let test = not (eq 1 2) in + if not test then failwithf "test 51 failed"; + let eq : enum3 @ local -> enum3 @ local -> bool = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in + let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in + mark_test_run 52; + let test = eq (mk_value 1) A3_1 in + if not test then failwithf "test 52 failed"; + mark_test_run 53; + let test = eq A3_1 A3_1 in + if not test then failwithf "test 53 failed"; + mark_test_run 54; + let test = not (eq A3_1 A3_2) in + if not test then failwithf "test 54 failed"; + let eq : ur2 @ local -> ur2 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in + mark_test_run 55; + let test = eq (mk_value 1) (#{ a = #1L; b = 1 } : ur2) in + if not test then failwithf "test 55 failed"; + mark_test_run 56; + let test = eq (#{ a = #1L; b = 1 } : ur2) (#{ a = #1L; b = 1 } : ur2) in + if not test then failwithf "test 56 failed"; + mark_test_run 57; + let test = not (eq (#{ a = #1L; b = 1 } : ur2) (#{ a = #2L; b = 2 } : ur2)) in + if not test then failwithf "test 57 failed"; + let eq : #(int * int64) @ local -> #(int * int64) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in + let mk_value i = #(i, Int64.of_int i) in + mark_test_run 58; + let test = eq (mk_value 1) #(1, 1L) in + if not test then failwithf "test 58 failed"; + mark_test_run 59; + let test = eq #(1, 1L) #(1, 1L) in + if not test then failwithf "test 59 failed"; + mark_test_run 60; + let test = not (eq #(1, 1L) #(2, 2L)) in + if not test then failwithf "test 60 failed"; + let eq : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) @ local -> #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in + let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in + mark_test_run 61; + let test = eq (mk_value 1) #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) in + if not test then failwithf "test 61 failed"; + mark_test_run 62; + let test = eq #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) in + if not test then failwithf "test 62 failed"; + mark_test_run 63; + let test = not (eq #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) #(Some 2L, #(2, 2l, 2.), 2., #(2.s, Some (2n, 2n)), 2l)) in + if not test then failwithf "test 63 failed"; + let eq : #(float * float * float) @ local -> #(float * float * float) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in + let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in + mark_test_run 64; + let test = eq (mk_value 1) #(1., 1., 1.) in + if not test then failwithf "test 64 failed"; + mark_test_run 65; + let test = eq #(1., 1., 1.) #(1., 1., 1.) in + if not test then failwithf "test 65 failed"; + mark_test_run 66; + let test = not (eq #(1., 1., 1.) #(2., 2., 2.)) in + if not test then failwithf "test 66 failed"; + let eq : #(float * #(float * float) * #(float * #(float * float * float))) @ local -> #(float * #(float * float) * #(float * #(float * float * float))) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in + let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in + mark_test_run 67; + let test = eq (mk_value 1) #(1., #(1., 1.), #(1., #(1., 1., 1.))) in + if not test then failwithf "test 67 failed"; + mark_test_run 68; + let test = eq #(1., #(1., 1.), #(1., #(1., 1., 1.))) #(1., #(1., 1.), #(1., #(1., 1., 1.))) in + if not test then failwithf "test 68 failed"; + mark_test_run 69; + let test = not (eq #(1., #(1., 1.), #(1., #(1., 1., 1.))) #(2., #(2., 2.), #(2., #(2., 2., 2.)))) in + if not test then failwithf "test 69 failed"; + let eq : #(float# * int * int64#) @ local -> #(float# * int * int64#) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in + mark_test_run 70; + let test = eq (mk_value 1) #(#1., 1, #1L) in + if not test then failwithf "test 70 failed"; + mark_test_run 71; + let test = eq #(#1., 1, #1L) #(#1., 1, #1L) in + if not test then failwithf "test 71 failed"; + mark_test_run 72; + let test = not (eq #(#1., 1, #1L) #(#2., 2, #2L)) in + if not test then failwithf "test 72 failed"; + let eq : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) @ local -> #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in + mark_test_run 73; + let test = eq (mk_value 1) #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) in + if not test then failwithf "test 73 failed"; + mark_test_run 74; + let test = eq #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) in + if not test then failwithf "test 74 failed"; + mark_test_run 75; + let test = not (eq #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) #(#2., #(2, #2L), #2.s, #(#2l, #(#2.s, #2.)), 2)) in + if not test then failwithf "test 75 failed"; + let eq : #(ur2 * ur1) @ local -> #(ur2 * ur1) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + mark_test_run 76; + let test = eq (mk_value 1) #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 76 failed"; + mark_test_run 77; + let test = eq #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 77 failed"; + mark_test_run 78; + let test = not (eq #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) #((#{ a = #2L; b = 2 } : ur2), (#{ a = #2L; b = #2. } : ur1))) in + if not test then failwithf "test 78 failed"; + (* Check always-GC-ignored types *) + let _ = (makearray_dynamic_uninit 1 : float32# array) in + let _ = (makearray_dynamic_uninit 1 : float# array) in + let _ = (makearray_dynamic_uninit 1 : int32# array) in + let _ = (makearray_dynamic_uninit 1 : int64# array) in + let _ = (makearray_dynamic_uninit 1 : nativeint# array) in + let _ = (makearray_dynamic_uninit 1 : ur1 array) in + let _ = (makearray_dynamic_uninit 1 : ur3 array) in + let _ = (makearray_dynamic_uninit 1 : ur4 array) in + let _ = (makearray_dynamic_uninit 1 : #(float# * int32# * int64#) array) in + let _ = (makearray_dynamic_uninit 1 : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array) in + let _ = (makearray_dynamic_uninit 1 : #(int64# * ur1) array) in + () +;; + +let test_makearray_dynamic size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic size #0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 79; + let test = eq el #0.s in + if not test then failwithf "test 79 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 80; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 80 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 81; + let test = raises in + if not test then failwithf "test 81 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 82; + let test = raises in + if not test then failwithf "test 82 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 83; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 83 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 84; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 84 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 85; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 85 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 86; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 86 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic size #0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 87; + let test = eq el #0. in + if not test then failwithf "test 87 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 88; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 88 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 89; + let test = raises in + if not test then failwithf "test 89 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 90; + let test = raises in + if not test then failwithf "test 90 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 91; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 91 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 92; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 92 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 93; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 93 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 94; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 94 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic size #0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 95; + let test = eq el #0l in + if not test then failwithf "test 95 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 96; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 96 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 97; + let test = raises in + if not test then failwithf "test 97 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 98; + let test = raises in + if not test then failwithf "test 98 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 99; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 99 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 100; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 100 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 101; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 101 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 102; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 102 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic size #0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 103; + let test = eq el #0L in + if not test then failwithf "test 103 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 104; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 104 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 105; + let test = raises in + if not test then failwithf "test 105 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 106; + let test = raises in + if not test then failwithf "test 106 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 107; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 107 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 108; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 108 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 109; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 109 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 110; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 110 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic size #0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 111; + let test = eq el #0n in + if not test then failwithf "test 111 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 112; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 112 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 113; + let test = raises in + if not test then failwithf "test 113 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 114; + let test = raises in + if not test then failwithf "test 114 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 115; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 115 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 116; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 116 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 117; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 117 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 118; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 118 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic size (#{ a = #0L; b = #0. } : ur1) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 119; + let test = eq el (#{ a = #0L; b = #0. } : ur1) in + if not test then failwithf "test 119 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 120; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 120 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 121; + let test = raises in + if not test then failwithf "test 121 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 122; + let test = raises in + if not test then failwithf "test 122 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 123; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 123 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 124; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 124 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 125; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 125 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 126; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 126 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic size (#{ a = #0L } : ur3) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 127; + let test = eq el (#{ a = #0L } : ur3) in + if not test then failwithf "test 127 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 128; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 128 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 129; + let test = raises in + if not test then failwithf "test 129 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 130; + let test = raises in + if not test then failwithf "test 130 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 131; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 131 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 132; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 132 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 133; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 133 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 134; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 134 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic size (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 135; + let test = eq el (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + if not test then failwithf "test 135 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 136; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 136 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 137; + let test = raises in + if not test then failwithf "test 137 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 138; + let test = raises in + if not test then failwithf "test 138 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 139; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 139 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 140; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 140 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 141; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 141 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 142; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 142 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic size #(#0., #0l, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 143; + let test = eq el #(#0., #0l, #0L) in + if not test then failwithf "test 143 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 144; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 144 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 145; + let test = raises in + if not test then failwithf "test 145 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 146; + let test = raises in + if not test then failwithf "test 146 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 147; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 147 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 148; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 148 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 149; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 149 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 150; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 150 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic size #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 151; + let test = eq el #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + if not test then failwithf "test 151 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 152; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 152 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 153; + let test = raises in + if not test then failwithf "test 153 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 154; + let test = raises in + if not test then failwithf "test 154 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 155; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 155 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 156; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 156 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 157; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 157 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 158; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 158 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic size #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 159; + let test = eq el #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 159 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 160; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 160 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 161; + let test = raises in + if not test then failwithf "test 161 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 162; + let test = raises in + if not test then failwithf "test 162 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 163; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 163 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 164; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 164 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 165; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 165 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 166; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 166 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************) + (* float32 *) + (***************) + let eq = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in + let mk_value i = Float32.of_int i in + (* 1. Create an array of size [size] *) + let a : float32 array = makearray_dynamic size 0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 167; + let test = eq el 0.s in + if not test then failwithf "test 167 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 168; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 168 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 169; + let test = raises in + if not test then failwithf "test 169 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 170; + let test = raises in + if not test then failwithf "test 170 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 171; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 171 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 172; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 172 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 173; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 173 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 174; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 174 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* float *) + (*************) + let eq = (fun a b -> Float.equal (globalize a) (globalize b)) in + let mk_value i = Float.of_int i in + (* 1. Create an array of size [size] *) + let a : float array = makearray_dynamic size 0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 175; + let test = eq el 0. in + if not test then failwithf "test 175 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 176; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 176 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 177; + let test = raises in + if not test then failwithf "test 177 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 178; + let test = raises in + if not test then failwithf "test 178 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 179; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 179 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 180; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 180 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 181; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 181 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 182; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 182 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int32 *) + (*************) + let eq = (fun a b -> Int32.equal (globalize a) (globalize b)) in + let mk_value i = Int32.of_int i in + (* 1. Create an array of size [size] *) + let a : int32 array = makearray_dynamic size 0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 183; + let test = eq el 0l in + if not test then failwithf "test 183 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 184; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 184 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 185; + let test = raises in + if not test then failwithf "test 185 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 186; + let test = raises in + if not test then failwithf "test 186 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 187; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 187 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 188; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 188 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 189; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 189 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 190; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 190 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int64 *) + (*************) + let eq = (fun a b -> Int64.equal (globalize a) (globalize b)) in + let mk_value i = Int64.of_int i in + (* 1. Create an array of size [size] *) + let a : int64 array = makearray_dynamic size 0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 191; + let test = eq el 0L in + if not test then failwithf "test 191 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 192; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 192 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 193; + let test = raises in + if not test then failwithf "test 193 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 194; + let test = raises in + if not test then failwithf "test 194 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 195; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 195 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 196; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 196 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 197; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 197 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 198; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 198 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*****************) + (* nativeint *) + (*****************) + let eq = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in + let mk_value i = Nativeint.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint array = makearray_dynamic size 0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 199; + let test = eq el 0n in + if not test then failwithf "test 199 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 200; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 200 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 201; + let test = raises in + if not test then failwithf "test 201 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 202; + let test = raises in + if not test then failwithf "test 202 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 203; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 203 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 204; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 204 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 205; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 205 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 206; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 206 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* int *) + (***********) + let eq = (fun a b -> Int.equal a b) in + let mk_value i = i in + (* 1. Create an array of size [size] *) + let a : int array = makearray_dynamic size 0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 207; + let test = eq el 0 in + if not test then failwithf "test 207 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 208; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 208 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 209; + let test = raises in + if not test then failwithf "test 209 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 210; + let test = raises in + if not test then failwithf "test 210 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 211; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 211 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 212; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 212 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 213; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 213 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 214; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 214 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* enum3 *) + (*************) + let eq = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in + let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in + (* 1. Create an array of size [size] *) + let a : enum3 array = makearray_dynamic size A3_0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 215; + let test = eq el A3_0 in + if not test then failwithf "test 215 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 216; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 216 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 217; + let test = raises in + if not test then failwithf "test 217 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i A3_0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 218; + let test = raises in + if not test then failwithf "test 218 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 219; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 219 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 220; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 220 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 221; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 221 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 222; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 222 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur2 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in + (* 1. Create an array of size [size] *) + let a : ur2 array = makearray_dynamic size (#{ a = #0L; b = 0 } : ur2) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 223; + let test = eq el (#{ a = #0L; b = 0 } : ur2) in + if not test then failwithf "test 223 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 224; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 224 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 225; + let test = raises in + if not test then failwithf "test 225 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = 0 } : ur2) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 226; + let test = raises in + if not test then failwithf "test 226 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 227; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 227 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 228; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 228 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 229; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 229 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 230; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 230 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**********************) + (* #(int * int64) *) + (**********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in + let mk_value i = #(i, Int64.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int * int64) array = makearray_dynamic size #(0, 0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 231; + let test = eq el #(0, 0L) in + if not test then failwithf "test 231 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 232; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 232 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 233; + let test = raises in + if not test then failwithf "test 233 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0, 0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 234; + let test = raises in + if not test then failwithf "test 234 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 235; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 235 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 236; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 236 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 237; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 237 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 238; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 238 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************************************************************************************************************) + (* #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) *) + (**************************************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in + let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) array = makearray_dynamic size #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 239; + let test = eq el #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + if not test then failwithf "test 239 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 240; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 240 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 241; + let test = raises in + if not test then failwithf "test 241 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 242; + let test = raises in + if not test then failwithf "test 242 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 243; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 243 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 244; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 244 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 245; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 245 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 246; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 246 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float * float * float) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in + let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float * float * float) array = makearray_dynamic size #(0., 0., 0.) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 247; + let test = eq el #(0., 0., 0.) in + if not test then failwithf "test 247 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 248; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 248 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 249; + let test = raises in + if not test then failwithf "test 249 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., 0., 0.) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 250; + let test = raises in + if not test then failwithf "test 250 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 251; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 251 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 252; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 252 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 253; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 253 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 254; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 254 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************************************************************************) + (* #(float * #(float * float) * #(float * #(float * float * float))) *) + (*************************************************************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in + let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in + (* 1. Create an array of size [size] *) + let a : #(float * #(float * float) * #(float * #(float * float * float))) array = makearray_dynamic size #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 255; + let test = eq el #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + if not test then failwithf "test 255 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 256; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 256 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 257; + let test = raises in + if not test then failwithf "test 257 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., #(0., 0.), #(0., #(0., 0., 0.))) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 258; + let test = raises in + if not test then failwithf "test 258 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 259; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 259 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 260; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 260 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 261; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 261 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 262; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 262 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float# * int * int64#) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int * int64#) array = makearray_dynamic size #(#0., 0, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 263; + let test = eq el #(#0., 0, #0L) in + if not test then failwithf "test 263 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 264; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 264 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 265; + let test = raises in + if not test then failwithf "test 265 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., 0, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 266; + let test = raises in + if not test then failwithf "test 266 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 267; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 267 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 268; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 268 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 269; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 269 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 270; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 270 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************************************************************************************) + (* #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) *) + (***************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) array = makearray_dynamic size #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 271; + let test = eq el #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + if not test then failwithf "test 271 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 272; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 272 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 273; + let test = raises in + if not test then failwithf "test 273 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 274; + let test = raises in + if not test then failwithf "test 274 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 275; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 275 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 276; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 276 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 277; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 277 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 278; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 278 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************) + (* #(ur2 * ur1) *) + (********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(ur2 * ur1) array = makearray_dynamic size #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 279; + let test = eq el #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 279 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 280; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 280 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 281; + let test = raises in + if not test then failwithf "test 281 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 282; + let test = raises in + if not test then failwithf "test 282 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 283; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 283 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 284; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 284 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 285; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 285 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 286; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 286 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +let test_makearray_dynamic_local size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic_local size #0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 287; + let test = eq el #0.s in + if not test then failwithf "test 287 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 288; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 288 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 289; + let test = raises in + if not test then failwithf "test 289 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 290; + let test = raises in + if not test then failwithf "test 290 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 291; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 291 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 292; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 292 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 293; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 293 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 294; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 294 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic_local size #0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 295; + let test = eq el #0. in + if not test then failwithf "test 295 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 296; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 296 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 297; + let test = raises in + if not test then failwithf "test 297 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 298; + let test = raises in + if not test then failwithf "test 298 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 299; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 299 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 300; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 300 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 301; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 301 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 302; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 302 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic_local size #0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 303; + let test = eq el #0l in + if not test then failwithf "test 303 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 304; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 304 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 305; + let test = raises in + if not test then failwithf "test 305 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 306; + let test = raises in + if not test then failwithf "test 306 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 307; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 307 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 308; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 308 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 309; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 309 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 310; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 310 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic_local size #0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 311; + let test = eq el #0L in + if not test then failwithf "test 311 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 312; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 312 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 313; + let test = raises in + if not test then failwithf "test 313 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 314; + let test = raises in + if not test then failwithf "test 314 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 315; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 315 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 316; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 316 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 317; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 317 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 318; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 318 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic_local size #0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 319; + let test = eq el #0n in + if not test then failwithf "test 319 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 320; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 320 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 321; + let test = raises in + if not test then failwithf "test 321 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 322; + let test = raises in + if not test then failwithf "test 322 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 323; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 323 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 324; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 324 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 325; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 325 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 326; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 326 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic_local size (#{ a = #0L; b = #0. } : ur1) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 327; + let test = eq el (#{ a = #0L; b = #0. } : ur1) in + if not test then failwithf "test 327 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 328; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 328 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 329; + let test = raises in + if not test then failwithf "test 329 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 330; + let test = raises in + if not test then failwithf "test 330 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 331; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 331 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 332; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 332 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 333; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 333 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 334; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 334 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic_local size (#{ a = #0L } : ur3) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 335; + let test = eq el (#{ a = #0L } : ur3) in + if not test then failwithf "test 335 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 336; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 336 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 337; + let test = raises in + if not test then failwithf "test 337 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 338; + let test = raises in + if not test then failwithf "test 338 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 339; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 339 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 340; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 340 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 341; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 341 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 342; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 342 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic_local size (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 343; + let test = eq el (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + if not test then failwithf "test 343 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 344; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 344 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 345; + let test = raises in + if not test then failwithf "test 345 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 346; + let test = raises in + if not test then failwithf "test 346 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 347; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 347 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 348; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 348 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 349; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 349 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 350; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 350 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic_local size #(#0., #0l, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 351; + let test = eq el #(#0., #0l, #0L) in + if not test then failwithf "test 351 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 352; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 352 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 353; + let test = raises in + if not test then failwithf "test 353 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 354; + let test = raises in + if not test then failwithf "test 354 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 355; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 355 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 356; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 356 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 357; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 357 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 358; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 358 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_local size #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 359; + let test = eq el #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + if not test then failwithf "test 359 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 360; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 360 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 361; + let test = raises in + if not test then failwithf "test 361 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 362; + let test = raises in + if not test then failwithf "test 362 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 363; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 363 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 364; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 364 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 365; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 365 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 366; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 366 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic_local size #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 367; + let test = eq el #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 367 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 368; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 368 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 369; + let test = raises in + if not test then failwithf "test 369 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 370; + let test = raises in + if not test then failwithf "test 370 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 371; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 371 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 372; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 372 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 373; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 373 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 374; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 374 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************) + (* float32 *) + (***************) + let eq = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in + let mk_value i = Float32.of_int i in + (* 1. Create an array of size [size] *) + let a : float32 array = makearray_dynamic_local size 0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 375; + let test = eq el 0.s in + if not test then failwithf "test 375 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 376; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 376 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 377; + let test = raises in + if not test then failwithf "test 377 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 378; + let test = raises in + if not test then failwithf "test 378 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 379; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 379 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 380; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 380 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 381; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 381 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 382; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 382 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* float *) + (*************) + let eq = (fun a b -> Float.equal (globalize a) (globalize b)) in + let mk_value i = Float.of_int i in + (* 1. Create an array of size [size] *) + let a : float array = makearray_dynamic_local size 0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 383; + let test = eq el 0. in + if not test then failwithf "test 383 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 384; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 384 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 385; + let test = raises in + if not test then failwithf "test 385 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 386; + let test = raises in + if not test then failwithf "test 386 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 387; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 387 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 388; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 388 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 389; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 389 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 390; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 390 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int32 *) + (*************) + let eq = (fun a b -> Int32.equal (globalize a) (globalize b)) in + let mk_value i = Int32.of_int i in + (* 1. Create an array of size [size] *) + let a : int32 array = makearray_dynamic_local size 0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 391; + let test = eq el 0l in + if not test then failwithf "test 391 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 392; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 392 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 393; + let test = raises in + if not test then failwithf "test 393 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 394; + let test = raises in + if not test then failwithf "test 394 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 395; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 395 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 396; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 396 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 397; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 397 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 398; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 398 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int64 *) + (*************) + let eq = (fun a b -> Int64.equal (globalize a) (globalize b)) in + let mk_value i = Int64.of_int i in + (* 1. Create an array of size [size] *) + let a : int64 array = makearray_dynamic_local size 0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 399; + let test = eq el 0L in + if not test then failwithf "test 399 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 400; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 400 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 401; + let test = raises in + if not test then failwithf "test 401 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 402; + let test = raises in + if not test then failwithf "test 402 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 403; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 403 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 404; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 404 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 405; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 405 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 406; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 406 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*****************) + (* nativeint *) + (*****************) + let eq = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in + let mk_value i = Nativeint.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint array = makearray_dynamic_local size 0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 407; + let test = eq el 0n in + if not test then failwithf "test 407 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 408; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 408 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 409; + let test = raises in + if not test then failwithf "test 409 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 410; + let test = raises in + if not test then failwithf "test 410 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 411; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 411 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 412; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 412 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 413; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 413 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 414; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 414 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* int *) + (***********) + let eq = (fun a b -> Int.equal a b) in + let mk_value i = i in + (* 1. Create an array of size [size] *) + let a : int array = makearray_dynamic_local size 0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 415; + let test = eq el 0 in + if not test then failwithf "test 415 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 416; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 416 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 417; + let test = raises in + if not test then failwithf "test 417 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 418; + let test = raises in + if not test then failwithf "test 418 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 419; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 419 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 420; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 420 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 421; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 421 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 422; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 422 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* enum3 *) + (*************) + let eq = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in + let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in + (* 1. Create an array of size [size] *) + let a : enum3 array = makearray_dynamic_local size A3_0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 423; + let test = eq el A3_0 in + if not test then failwithf "test 423 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 424; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 424 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 425; + let test = raises in + if not test then failwithf "test 425 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i A3_0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 426; + let test = raises in + if not test then failwithf "test 426 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 427; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 427 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 428; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 428 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 429; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 429 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 430; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 430 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur2 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in + (* 1. Create an array of size [size] *) + let a : ur2 array = makearray_dynamic_local size (#{ a = #0L; b = 0 } : ur2) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 431; + let test = eq el (#{ a = #0L; b = 0 } : ur2) in + if not test then failwithf "test 431 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 432; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 432 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 433; + let test = raises in + if not test then failwithf "test 433 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = 0 } : ur2) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 434; + let test = raises in + if not test then failwithf "test 434 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 435; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 435 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 436; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 436 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 437; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 437 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 438; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 438 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**********************) + (* #(int * int64) *) + (**********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in + let mk_value i = #(i, Int64.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int * int64) array = makearray_dynamic_local size #(0, 0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 439; + let test = eq el #(0, 0L) in + if not test then failwithf "test 439 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 440; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 440 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 441; + let test = raises in + if not test then failwithf "test 441 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0, 0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 442; + let test = raises in + if not test then failwithf "test 442 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 443; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 443 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 444; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 444 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 445; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 445 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 446; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 446 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************************************************************************************************************) + (* #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) *) + (**************************************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in + let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) array = makearray_dynamic_local size #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 447; + let test = eq el #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + if not test then failwithf "test 447 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 448; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 448 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 449; + let test = raises in + if not test then failwithf "test 449 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 450; + let test = raises in + if not test then failwithf "test 450 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 451; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 451 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 452; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 452 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 453; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 453 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 454; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 454 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float * float * float) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in + let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float * float * float) array = makearray_dynamic_local size #(0., 0., 0.) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 455; + let test = eq el #(0., 0., 0.) in + if not test then failwithf "test 455 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 456; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 456 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 457; + let test = raises in + if not test then failwithf "test 457 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., 0., 0.) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 458; + let test = raises in + if not test then failwithf "test 458 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 459; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 459 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 460; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 460 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 461; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 461 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 462; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 462 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************************************************************************) + (* #(float * #(float * float) * #(float * #(float * float * float))) *) + (*************************************************************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in + let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in + (* 1. Create an array of size [size] *) + let a : #(float * #(float * float) * #(float * #(float * float * float))) array = makearray_dynamic_local size #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 463; + let test = eq el #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + if not test then failwithf "test 463 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 464; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 464 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 465; + let test = raises in + if not test then failwithf "test 465 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., #(0., 0.), #(0., #(0., 0., 0.))) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 466; + let test = raises in + if not test then failwithf "test 466 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 467; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 467 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 468; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 468 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 469; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 469 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 470; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 470 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float# * int * int64#) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int * int64#) array = makearray_dynamic_local size #(#0., 0, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 471; + let test = eq el #(#0., 0, #0L) in + if not test then failwithf "test 471 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 472; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 472 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 473; + let test = raises in + if not test then failwithf "test 473 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., 0, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 474; + let test = raises in + if not test then failwithf "test 474 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 475; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 475 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 476; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 476 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 477; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 477 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 478; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 478 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************************************************************************************) + (* #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) *) + (***************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) array = makearray_dynamic_local size #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 479; + let test = eq el #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + if not test then failwithf "test 479 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 480; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 480 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 481; + let test = raises in + if not test then failwithf "test 481 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 482; + let test = raises in + if not test then failwithf "test 482 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 483; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 483 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 484; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 484 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 485; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 485 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 486; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 486 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************) + (* #(ur2 * ur1) *) + (********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(ur2 * ur1) array = makearray_dynamic_local size #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 487; + let test = eq el #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 487 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 488; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 488 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 489; + let test = raises in + if not test then failwithf "test 489 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 490; + let test = raises in + if not test then failwithf "test 490 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 491; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 491 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 492; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 492 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 493; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 493 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 494; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 494 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +let test_makearray_dynamic_uninit size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 495; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 495 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 496; + let test = raises in + if not test then failwithf "test 496 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 497; + let test = raises in + if not test then failwithf "test 497 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 498; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 498 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 499; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 499 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 500; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 500 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 501; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 501 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 502; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 502 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 503; + let test = raises in + if not test then failwithf "test 503 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 504; + let test = raises in + if not test then failwithf "test 504 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 505; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 505 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 506; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 506 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 507; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 507 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 508; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 508 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 509; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 509 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 510; + let test = raises in + if not test then failwithf "test 510 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 511; + let test = raises in + if not test then failwithf "test 511 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 512; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 512 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 513; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 513 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 514; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 514 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 515; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 515 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 516; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 516 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 517; + let test = raises in + if not test then failwithf "test 517 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 518; + let test = raises in + if not test then failwithf "test 518 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 519; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 519 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 520; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 520 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 521; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 521 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 522; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 522 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 523; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 523 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 524; + let test = raises in + if not test then failwithf "test 524 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 525; + let test = raises in + if not test then failwithf "test 525 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 526; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 526 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 527; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 527 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 528; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 528 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 529; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 529 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 530; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 530 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 531; + let test = raises in + if not test then failwithf "test 531 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 532; + let test = raises in + if not test then failwithf "test 532 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 533; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 533 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 534; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 534 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 535; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 535 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 536; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 536 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 537; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 537 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 538; + let test = raises in + if not test then failwithf "test 538 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 539; + let test = raises in + if not test then failwithf "test 539 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 540; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 540 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 541; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 541 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 542; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 542 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 543; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 543 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 544; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 544 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 545; + let test = raises in + if not test then failwithf "test 545 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 546; + let test = raises in + if not test then failwithf "test 546 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 547; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 547 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 548; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 548 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 549; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 549 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 550; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 550 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 551; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 551 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 552; + let test = raises in + if not test then failwithf "test 552 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 553; + let test = raises in + if not test then failwithf "test 553 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 554; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 554 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 555; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 555 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 556; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 556 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 557; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 557 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 558; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 558 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 559; + let test = raises in + if not test then failwithf "test 559 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 560; + let test = raises in + if not test then failwithf "test 560 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 561; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 561 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 562; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 562 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 563; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 563 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 564; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 564 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 565; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 565 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 566; + let test = raises in + if not test then failwithf "test 566 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 567; + let test = raises in + if not test then failwithf "test 567 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 568; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 568 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 569; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 569 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 570; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 570 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 571; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 571 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +let test_makearray_dynamic_uninit_local size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 572; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 572 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 573; + let test = raises in + if not test then failwithf "test 573 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 574; + let test = raises in + if not test then failwithf "test 574 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 575; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 575 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 576; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 576 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 577; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 577 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 578; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 578 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 579; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 579 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 580; + let test = raises in + if not test then failwithf "test 580 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 581; + let test = raises in + if not test then failwithf "test 581 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 582; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 582 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 583; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 583 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 584; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 584 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 585; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 585 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 586; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 586 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 587; + let test = raises in + if not test then failwithf "test 587 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 588; + let test = raises in + if not test then failwithf "test 588 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 589; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 589 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 590; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 590 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 591; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 591 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 592; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 592 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 593; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 593 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 594; + let test = raises in + if not test then failwithf "test 594 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 595; + let test = raises in + if not test then failwithf "test 595 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 596; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 596 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 597; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 597 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 598; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 598 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 599; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 599 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 600; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 600 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 601; + let test = raises in + if not test then failwithf "test 601 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 602; + let test = raises in + if not test then failwithf "test 602 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 603; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 603 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 604; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 604 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 605; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 605 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 606; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 606 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 607; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 607 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 608; + let test = raises in + if not test then failwithf "test 608 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 609; + let test = raises in + if not test then failwithf "test 609 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 610; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 610 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 611; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 611 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 612; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 612 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 613; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 613 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 614; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 614 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 615; + let test = raises in + if not test then failwithf "test 615 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 616; + let test = raises in + if not test then failwithf "test 616 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 617; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 617 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 618; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 618 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 619; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 619 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 620; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 620 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 621; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 621 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 622; + let test = raises in + if not test then failwithf "test 622 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 623; + let test = raises in + if not test then failwithf "test 623 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 624; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 624 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 625; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 625 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 626; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 626 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 627; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 627 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 628; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 628 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 629; + let test = raises in + if not test then failwithf "test 629 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 630; + let test = raises in + if not test then failwithf "test 630 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 631; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 631 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 632; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 632 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 633; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 633 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 634; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 634 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 635; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 635 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 636; + let test = raises in + if not test then failwithf "test 636 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 637; + let test = raises in + if not test then failwithf "test 637 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 638; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 638 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 639; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 639 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 640; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 640 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 641; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 641 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 642; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 642 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 643; + let test = raises in + if not test then failwithf "test 643 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 644; + let test = raises in + if not test then failwithf "test 644 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 645; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 645 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 646; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 646 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 647; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 647 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 648; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 648 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +(* Main tests *) +let () = + print_endline "test_makearray_dynamic"; + iter sizes ~f:test_makearray_dynamic; + print_endline "test_makearray_dynamic_local"; + iter sizes ~f:test_makearray_dynamic_local; + print_endline "test_makearray_dynamic_uninit"; + iter sizes ~f:test_makearray_dynamic_uninit; + print_endline "test_makearray_dynamic_uninit_local"; + iter sizes ~f:test_makearray_dynamic_uninit_local; + () +;; + +for i = 1 to 648 do + if not (List.mem ~set:!tests_run i) then failwithf "test %d not run" i +done;; +let () = Printf.printf "All tests passed.%!\n";; diff --git a/testsuite/tests/typing-layouts-arrays/generated_test.reference b/testsuite/tests/typing-layouts-arrays/generated_test.reference new file mode 100644 index 00000000000..c2075fa9659 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/generated_test.reference @@ -0,0 +1,5 @@ +test_makearray_dynamic +test_makearray_dynamic_local +test_makearray_dynamic_uninit +test_makearray_dynamic_uninit_local +All tests passed. diff --git a/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml b/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml new file mode 100644 index 00000000000..3dd358ae67c --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml @@ -0,0 +1,24 @@ +(* TEST + readonly_files = "generate_makearray_dynamic_tests.ml"; + (* Generate the bytecode/native code versions of + [generate_makearray_dynamic_tests.ml]. This doesn't actually run the test; + it just updates the generated test program (which is separately + run by the test harness). + *) + + { + setup-ocamlopt.opt-build-env; + stack-allocation; + program = "${test_source_directory}/generate.out"; + all_modules = "generate_makearray_dynamic_tests.ml"; + include stdlib_stable; + include stdlib_upstream_compatible; + ocamlopt.opt; + arguments = "native"; + output = "${test_source_directory}/generated_test.ml.corrected"; + run; + output = "${test_source_directory}/generated_test.ml.corrected"; + reference = "${test_source_directory}/generated_test.ml"; + check-program-output; + } +*) diff --git a/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml b/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml new file mode 100644 index 00000000000..81dd9df04e0 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml @@ -0,0 +1,93 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float +type unboxed_t = float# + +let elem : boxed_t elem = float_elem +let words_wide : int = 1 +let zero () : unboxed_t = #0. + +let to_boxed a = Float_u.to_float a +let of_boxed a = Float_u.of_float a + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module Float_u_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module Float_u_array = Gen_u_array.Make (Float_u_array0) + +module Float_u_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = Float_u_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (Float_u_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml new file mode 100644 index 00000000000..05b59f4ee0b --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml @@ -0,0 +1,93 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * int * int64 +type unboxed_t = #(float# * int * int64#) + +let elem : boxed_t elem = Tup3 (float_elem, int_elem, int64_elem) +let words_wide : int = 3 +let zero () : unboxed_t = #(#0., 0, #0L) + +let to_boxed #(a, b, c) = (Float_u.to_float a, b, Int64_u.to_int64 c) +let of_boxed (a, b, c) = #(Float_u.of_float a, b, Int64_u.of_int64 c) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml new file mode 100644 index 00000000000..4ce8c2a43d5 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml @@ -0,0 +1,114 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = + float * (int * int64) * float32 * (int32 * (float32 * float)) * int +type unboxed_t = + #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) + * int) + +let elem : boxed_t elem = + Tup5 (float_elem, + Tup2 (int_elem, int64_elem), + float32_elem, + Tup2 (int32_elem, (Tup2 (float32_elem, float_elem))), + int_elem) + +let words_wide : int = 8 +let zero () : unboxed_t = + #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) + +let to_boxed #(a, #(b, c), d, #(e, #(f, g)), h) = + (Float_u.to_float a, + (b, Int64_u.to_int64 c), + Float32_u.to_float32 d, + (Int32_u.to_int32 e, (Float32_u.to_float32 f, Float_u.to_float g)), + h) + +let of_boxed (a, (b, c), d, (e, (f, g)), h) = + #(Float_u.of_float a, + #(b, Int64_u.of_int64 c), + Float32_u.of_float32 d, + #(Int32_u.of_int32 e, #(Float32_u.of_float32 f, Float_u.of_float g)), + h) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml new file mode 100644 index 00000000000..4dc10e586f7 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml @@ -0,0 +1,90 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * int32 * int64 +type unboxed_t = #(float# * int32# * int64#) + +let elem : boxed_t elem = Tup3 (float_elem, int32_elem, int64_elem) +let words_wide : int = 3 +let zero () : unboxed_t = #(#0., #0l, #0L) + +let to_boxed #(a, b, c) = (Float_u.to_float a, Int32_u.to_int32 b, Int64_u.to_int64 c) +let of_boxed (a, b, c) = #(Float_u.of_float a, Int32_u.of_int32 b, Int64_u.of_int64 c) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic_uninit : int -> element_t array = + "%makearray_dynamic_uninit" + + let unsafe_create : int -> element_t array = + fun i -> makearray_dynamic_uninit i + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml new file mode 100644 index 00000000000..1381e82f68e --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml @@ -0,0 +1,111 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = + float * (int64 * int64) * float32 * (int32 * (float32 * float)) * int64 +type unboxed_t = + #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) + * int64#) + +let elem : boxed_t elem = + Tup5 (float_elem, + Tup2 (int64_elem, int64_elem), + float32_elem, + Tup2 (int32_elem, (Tup2 (float32_elem, float_elem))), + int64_elem) + +let words_wide : int = 8 +let zero () : unboxed_t = + #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) + +let to_boxed #(a, #(b, c), d, #(e, #(f, g)), h) = + (Float_u.to_float a, + (Int64_u.to_int64 b, Int64_u.to_int64 c), + Float32_u.to_float32 d, + (Int32_u.to_int32 e, (Float32_u.to_float32 f, Float_u.to_float g)), + Int64_u.to_int64 h) + +let of_boxed (a, (b, c), d, (e, (f, g)), h) = + #(Float_u.of_float a, + #(Int64_u.of_int64 b, Int64_u.of_int64 c), + Float32_u.of_float32 d, + #(Int32_u.of_int32 e, #(Float32_u.of_float32 f, Float_u.of_float g)), + Int64_u.of_int64 h) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic_uninit : int -> element_t array = + "%makearray_dynamic_uninit" + + let unsafe_create : int -> element_t array = + fun i -> makearray_dynamic_uninit i + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml new file mode 100644 index 00000000000..33daf2c9485 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml @@ -0,0 +1,94 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = int * int64 +type unboxed_t = #(int * int64) + +let elem : boxed_t elem = Tup2 (int_elem, int64_elem) +let words_wide : int = 2 +let zero () : unboxed_t = #(0, 0L) + +let to_boxed #(i, i64) = (i, i64) +let of_boxed (i, i64) = #(i, i64) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml new file mode 100644 index 00000000000..1d64378a6ba --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml @@ -0,0 +1,116 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = + int64 option + * (int * int32 * float) + * float + * (float32 * (nativeint * nativeint) option) + * int32 + +type unboxed_t = + #(int64 option + * #(int * int32 * float) + * float + * #(float32 * (nativeint * nativeint) option) + * int32) + +let elem : boxed_t elem = + Tup5 (Option int64_elem, + Tup3 (int_elem, int32_elem, float_elem), + float_elem, + Tup2 (float32_elem, Option (Tup2 (nativeint_elem, nativeint_elem))), + int32_elem) + +let words_wide : int = 8 +let zero () : unboxed_t = + #(Some 0L, + #(0, 0l, 0.), + 0., + #(0.s, Some (0n, 0n)), + 0l) + +let to_boxed #(a, #(b, c, d), e, #(f, g), h) = (a, (b, c, d), e, (f, g), h) +let of_boxed (a, (b, c, d), e, (f, g), h) = #(a, #(b, c, d), e, #(f, g), h) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml new file mode 100644 index 00000000000..b18e167c7aa --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml @@ -0,0 +1,96 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * float * float + +type unboxed_t = #(float * float * float) + +let elem : boxed_t elem = Tup3 (float_elem, float_elem, float_elem) + +let words_wide : int = 3 +let zero () : unboxed_t = #(0., 0., 0.) + +let to_boxed #(a, b, c) = a, b, c +let of_boxed (a, b, c) = #(a, b, c) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml new file mode 100644 index 00000000000..19aa03f400a --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml @@ -0,0 +1,100 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * (float * float) * (float * (float * float * float)) + +type unboxed_t = + #(float * #(float * float) * #(float * #(float * float * float))) + +let elem : boxed_t elem = + Tup3 (float_elem, + Tup2 (float_elem, float_elem), + Tup2 (float_elem, Tup3 (float_elem, float_elem, float_elem))) + +let words_wide : int = 7 +let zero () : unboxed_t = #(0., #(0., 0.), #(0., #(0., 0., 0.))) + +let to_boxed #(a, #(b, c), #(d, #(e, f, g))) = a, (b, c), (d, (e, f, g)) +let of_boxed (a, (b, c), (d, (e, f, g))) = #(a, #(b, c), #(d, #(e, g, f))) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-products/basics.ml b/testsuite/tests/typing-layouts-products/basics.ml index 8f70d0b47ed..efb651516c7 100644 --- a/testsuite/tests/typing-layouts-products/basics.ml +++ b/testsuite/tests/typing-layouts-products/basics.ml @@ -1,9 +1,6 @@ (* TEST flambda2; include stdlib_upstream_compatible; - { - expect; - } { flags = "-extension layouts_beta"; expect; @@ -786,13 +783,7 @@ type t4 = #(string * #(float# * bool option)) array arrays to beta. *) let _ = [| #(1,2) |] [%%expect{| -Line 1, characters 8-20: -1 | let _ = [| #(1,2) |] - ^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type #(int * int), - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. +- : #(int * int) array = [|#(1, 2)|] |}] let _ = Array.init 3 (fun _ -> #(1,2)) @@ -836,13 +827,7 @@ let f x : #(int * int) = array_get x 3 [%%expect{| external array_get : ('a : any_non_null). 'a array -> int -> 'a = "%array_safe_get" [@@layout_poly] -Line 3, characters 25-38: -3 | let f x : #(int * int) = array_get x 3 - ^^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type #(int * int), - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. +val f : #(int * int) array -> #(int * int) = |}] external[@layout_poly] array_set : ('a : any_non_null) . 'a array -> int -> 'a -> unit = @@ -851,13 +836,7 @@ let f x = array_set x 3 #(1,2) [%%expect{| external array_set : ('a : any_non_null). 'a array -> int -> 'a -> unit = "%array_safe_set" [@@layout_poly] -Line 3, characters 10-30: -3 | let f x = array_set x 3 #(1,2) - ^^^^^^^^^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type #(int * int), - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. +val f : #(int * int) array -> unit = |}] diff --git a/testsuite/tests/typing-layouts-products/product_arrays.ml b/testsuite/tests/typing-layouts-products/product_arrays.ml index 2aaeeeec00e..a8765e1c10b 100644 --- a/testsuite/tests/typing-layouts-products/product_arrays.ml +++ b/testsuite/tests/typing-layouts-products/product_arrays.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha"; + flags = "-extension layouts_beta"; { expect; } @@ -13,7 +13,7 @@ (* CR layouts v7.1: The PR with middle-end support for product arrays can move this test to beta. *) -(* CR layouts v7.1: Everywhere this file says "any_non_null" it should instead +(* CR layouts v7.1: Everywhere this file says "any" it should instead say any. This is caused by [any] meaning different things alpha and beta - we can fix it when we move this test to beta. *) @@ -1864,10 +1864,8 @@ external blit_scannable : #(int * float * string) array -> int -> #(int * float * string) array -> int -> int -> unit = "%arrayblit" val blit_scannable_app : - ('a : value_or_null). - #(int * float * string) array -> - 'a -> #(int * float * string) array -> int -> int -> unit = - + #(int * float * string) array -> + 'a -> #(int * float * string) array -> int -> int -> unit = external blit_ignorable : #(float# * int * int64# * bool) array -> int -> #(float# * int * int64# * bool) array -> int -> int -> unit diff --git a/testsuite/tests/typing-layouts-products/product_iarrays.ml b/testsuite/tests/typing-layouts-products/product_iarrays.ml index 82773c9e516..261b8950263 100644 --- a/testsuite/tests/typing-layouts-products/product_iarrays.ml +++ b/testsuite/tests/typing-layouts-products/product_iarrays.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha"; + flags = "-extension layouts_beta"; { expect; } diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml index f48ce4c38d0..1152e2d3528 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml @@ -813,13 +813,7 @@ type array_record = #{ i1 : int; i2 : int } let _ = [| #{ i1 = 1; i2 = 2 } |] [%%expect{| type array_record = #{ i1 : int; i2 : int; } -Line 2, characters 8-33: -2 | let _ = [| #{ i1 = 1; i2 = 2 } |] - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type array_record, - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. +- : array_record array = [|#{i1 = 1; i2 = 2}|] |}] type array_init_record = #{ i1 : int; i2 : int } diff --git a/testsuite/tests/typing-layouts/layout_poly.ml b/testsuite/tests/typing-layouts/layout_poly.ml index acbd1dd0d0c..8037325d149 100644 --- a/testsuite/tests/typing-layouts/layout_poly.ml +++ b/testsuite/tests/typing-layouts/layout_poly.ml @@ -1,10 +1,6 @@ (* TEST include stdlib_upstream_compatible; { - flags = "-extension layouts"; - expect; - }{ - flags = "-extension layouts_beta"; expect; } *) @@ -715,8 +711,8 @@ Error: "[@layout_poly]" on this external declaration has no variable for it to operate on. |}] -(***********************************************) -(* New untested array prims are gated to alpha *) +(********************************************************) +(* Newer prims are gated to appropriate maturity levels *) external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = "%makearray_dynamic" @@ -724,7 +720,7 @@ external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a Lines 1-2, characters 0-22: 1 | external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = 2 | "%makearray_dynamic" -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used |}] external[@layout_poly] arrayblit : @@ -735,5 +731,14 @@ Lines 1-3, characters 0-14: 1 | external[@layout_poly] arrayblit : 2 | ('a : any_non_null). 'a array -> int -> 'a array -> int -> int -> unit = 3 | "%arrayblit" -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + +external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = + "%makearray_dynamic_uninit" +[%%expect{| +Lines 1-2, characters 0-29: +1 | external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = +2 | "%makearray_dynamic_uninit" +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used |}] diff --git a/typing/primitive.ml b/typing/primitive.ml index d2cc075844f..272b58674af 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -674,6 +674,12 @@ let prim_has_valid_reprs ~loc prim = any; is (Same_as_ocaml_repr C.value); ] + | "%makearray_dynamic_uninit" -> + (* Restrictions on this primitive are checked in [Translprim] *) + check [ + is (Same_as_ocaml_repr C.value); + is (Same_as_ocaml_repr C.value); + ] | "%box_float" -> exactly [Same_as_ocaml_repr C.float64; Same_as_ocaml_repr C.value] diff --git a/typing/typeopt.ml b/typing/typeopt.ml index a314ab84e5a..c20a17830fc 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -228,7 +228,7 @@ let array_kind_of_elt ~elt_sort env loc ty = (type_legacy_sort ~why:Array_element env loc ty) in let classify_product ty sorts = - if Language_extension.(is_at_least Layouts Alpha) then + if Language_extension.(is_at_least Layouts Beta) then if is_always_gc_ignorable env ty then Pgcignorableproductarray (ignorable_product_array_kind loc sorts) else From 65c059600ca67edb3cd1c8c40baa58168b51ee90 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Mon, 23 Dec 2024 16:49:37 -0500 Subject: [PATCH 03/30] Convert float32 constants to int32 in first stage compiler (#3371) * convert float32 constants in bytecode output * edit * edit * blocks + test * compare against float64 constants * tests check proper custom ops --------- Co-authored-by: Diana Kalinichenko --- bytecomp/bytegen.ml | 27 ++++++++++++++++++- bytecomp/symtable.ml | 9 ++++--- .../tests/small_numbers/float32_builtin.ml | 23 ++++++++++++++++ .../tests/small_numbers/float32_lib.ml | 14 +++++++++- flambda-backend/tests/small_numbers/stubs.c | 6 +++++ .../flambda2/numbers/floats/float32_stubs.c | 11 +++++--- runtime/float32.c | 5 ++++ runtime4/float32.c | 5 ++++ typing/oprint.ml | 1 + 9 files changed, 93 insertions(+), 8 deletions(-) diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 73b0160071f..3691b1f0515 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -755,7 +755,30 @@ module Storer = cont = list of instructions to execute afterwards Result = list of instructions that evaluate exp, then perform cont. *) -let rec comp_expr stack_info env exp sz cont = +(* We cannot use the [float32] type in the compiler. *) +external float32_is_stage1 : unit -> bool = "caml_float32_is_stage1" +external float32_of_string : string -> Obj.t = "caml_float32_of_string" + +let rec contains_float32s = function + | Const_base (Const_float32 _ | Const_unboxed_float32 _) -> true + | Const_block (_, fields) -> List.exists contains_float32s fields + | Const_mixed_block _ -> Misc.fatal_error "[Const_mixed_block] not supported in bytecode." + | _ -> false + +let rec translate_float32s stack_info env cst sz cont = + match cst with + | Const_base (Const_float32 f | Const_unboxed_float32 f) -> + let i = float32_of_string f in + Kconst (Const_base (Const_int32 (Obj.obj i))) :: + Kccall("caml_float32_of_bits_bytecode", 1) :: cont + | Const_block (tag, fields) as cst when contains_float32s cst -> + let fields = List.map (fun field -> Lconst field) fields in + let cont = Kmakeblock (List.length fields, tag) :: cont in + comp_args stack_info env fields sz cont + | Const_mixed_block _ -> Misc.fatal_error "[Const_mixed_block] not supported in bytecode." + | _ as cst -> Kconst cst :: cont + +and comp_expr stack_info env exp sz cont = check_stack stack_info sz; match exp with Lvar id | Lmutvar id -> @@ -776,6 +799,8 @@ let rec comp_expr stack_info env exp sz cont = Koffsetclosure(pos - env_pos) :: cont | exception Not_found -> not_found () end + | Lconst cst when float32_is_stage1 () -> + translate_float32s stack_info env cst sz cont | Lconst cst -> Kconst cst :: cont | Lapply{ap_func = func; ap_args = args; ap_region_close = rc} -> diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index eccebf4d8b8..9e43ec781eb 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -268,8 +268,8 @@ let patch_object buff patchlist = (* Translate structured constants *) -(* We cannot use the [float32] type in the compiler, so we represent it as an - opaque [Obj.t]. This is sufficient for interfacing with the runtime. *) +(* We cannot use the [float32] type in the compiler. *) +external float32_is_stage1 : unit -> bool = "caml_float32_is_stage1" external float32_of_string : string -> Obj.t = "caml_float32_of_string" let rec transl_const = function @@ -277,7 +277,10 @@ let rec transl_const = function | Const_base(Const_char c) -> Obj.repr c | Const_base(Const_string (s, _, _)) -> Obj.repr s | Const_base(Const_float32 f) - | Const_base(Const_unboxed_float32 f) -> float32_of_string f + | Const_base(Const_unboxed_float32 f) -> + if float32_is_stage1 () + then Misc.fatal_error "The stage one bytecode compiler should not produce float32 constants." + else Obj.repr (float32_of_string f) | Const_base(Const_float f) | Const_base(Const_unboxed_float f) -> Obj.repr (float_of_string f) | Const_base(Const_int32 i) diff --git a/flambda-backend/tests/small_numbers/float32_builtin.ml b/flambda-backend/tests/small_numbers/float32_builtin.ml index dbaaffbb125..4697ce7a363 100644 --- a/flambda-backend/tests/small_numbers/float32_builtin.ml +++ b/flambda-backend/tests/small_numbers/float32_builtin.ml @@ -54,6 +54,8 @@ end module CFloat32 = struct type t = float32 + external is_boxed_float32 : t -> bool = "float32_is_boxed_float32" [@@noalloc] + external bits_to_int : (t [@unboxed]) -> (int32 [@unboxed]) = "float32_bits_to_int_boxed" "float32_bits_to_int" [@@noalloc] external zero : unit -> (t [@unboxed]) = "float32_zero_boxed" "float32_zero" [@@noalloc] @@ -313,3 +315,24 @@ let () = (* Literals *) check 0x8p+124s 0x8p+124; () ;; + +type v = + | A of float32 * float * int + | B of int * (float32 * float32) + +let check f32 f64 = assert (CFloat32.is_boxed_float32 f32 && f32 = Float32.of_float f64) + +let () = (* Static constants *) + let x = Sys.opaque_identity 1.0s in + check x 1.0; + let block = Sys.opaque_identity ((0.0, 123), 2.0s, "hello", (3.0s, 4.0)) in + let (_, x, _, (y, _)) = block in + check x 2.0; + check y 3.0; + let block = Sys.opaque_identity (B (0, (5.0s, 6.0s))) in + match block with + | A _ -> assert false + | B (_, (x, y)) -> + check x 5.0; + check y 6.0 +;; diff --git a/flambda-backend/tests/small_numbers/float32_lib.ml b/flambda-backend/tests/small_numbers/float32_lib.ml index fedc7e296ef..352c5986288 100644 --- a/flambda-backend/tests/small_numbers/float32_lib.ml +++ b/flambda-backend/tests/small_numbers/float32_lib.ml @@ -9,6 +9,8 @@ module F32 = Stdlib_stable.Float32 module CF32 = struct type t = float32 + external is_boxed_float32 : t -> bool = "float32_is_boxed_float32" [@@noalloc] + external to_bits : (t [@unboxed]) -> (int32 [@unboxed]) = "float32_bits_to_int_boxed" "float32_bits_to_int" [@@noalloc] external of_int : (int [@untagged]) -> (t [@unboxed]) = "float32_of_int_boxed" "float32_of_int" [@@noalloc] @@ -165,7 +167,17 @@ let () = bit_eq F32.pi CF32.pi; bit_eq F32.min_float CF32.minv; bit_eq F32.max_float CF32.maxv; - bit_eq F32.epsilon CF32.epsilon + bit_eq F32.epsilon CF32.epsilon; + assert (CF32.is_boxed_float32 F32.zero); + assert (CF32.is_boxed_float32 F32.one); + assert (CF32.is_boxed_float32 F32.minus_one); + assert (CF32.is_boxed_float32 F32.infinity); + assert (CF32.is_boxed_float32 F32.neg_infinity); + assert (CF32.is_boxed_float32 F32.nan); + assert (CF32.is_boxed_float32 F32.pi); + assert (CF32.is_boxed_float32 F32.min_float); + assert (CF32.is_boxed_float32 F32.max_float); + assert (CF32.is_boxed_float32 F32.epsilon); ;; let () = diff --git a/flambda-backend/tests/small_numbers/stubs.c b/flambda-backend/tests/small_numbers/stubs.c index 561d1c9559c..688442ed9e0 100644 --- a/flambda-backend/tests/small_numbers/stubs.c +++ b/flambda-backend/tests/small_numbers/stubs.c @@ -2,8 +2,14 @@ #include #include #include +#include #include #include +#include + +value float32_is_boxed_float32(value f) { + return Val_bool(strcmp(Custom_ops_val(f)->identifier, "_f32") == 0); +} int32_t float32_bits_to_int(float f) { return *(int32_t *)&f; } float float32_of_int(intnat i) { return (float)i; } diff --git a/middle_end/flambda2/numbers/floats/float32_stubs.c b/middle_end/flambda2/numbers/floats/float32_stubs.c index f99c6d848cc..dc950a20f47 100644 --- a/middle_end/flambda2/numbers/floats/float32_stubs.c +++ b/middle_end/flambda2/numbers/floats/float32_stubs.c @@ -335,9 +335,14 @@ CAMLprim value compiler_float32_format(value fmt, value arg) return res; } -// These replace the OCaml runtime versions for use under ocaml/ in the dune build. -// They must have the same name as in the runtime because building ocaml/ with the -// upstream build system calls it by name. +// These replace the OCaml runtime versions for use in the stage one compiler. +// They must be weak symbols with the same names as in runtime/ because the stage +// two compiler will link against runtime/. + +CAMLweakdef value caml_float32_is_stage1(value v) { + (void)v; + return Val_true; +} CAMLweakdef value caml_float32_of_string(value vs) { return compiler_float32_of_string(vs); diff --git a/runtime/float32.c b/runtime/float32.c index e57e94e1e64..6c4cce4cc7a 100644 --- a/runtime/float32.c +++ b/runtime/float32.c @@ -900,3 +900,8 @@ CAMLprim value caml_unboxed_float32_vect_blit(value a1, value ofs1, value a2, Long_val(n) * sizeof(float)); return Val_unit; } + +CAMLprim value caml_float32_is_stage1(value v) { + (void)v; + return Val_false; +} diff --git a/runtime4/float32.c b/runtime4/float32.c index 3fb8654d4a5..5261e191efe 100644 --- a/runtime4/float32.c +++ b/runtime4/float32.c @@ -895,3 +895,8 @@ CAMLprim value caml_unboxed_float32_vect_blit(value a1, value ofs1, value a2, Long_val(n) * sizeof(float)); return Val_unit; } + +CAMLprim value caml_float32_is_stage1(value v) { + (void)v; + return Val_false; +} diff --git a/typing/oprint.ml b/typing/oprint.ml index a1b75512ddf..914bff8f8e7 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -197,6 +197,7 @@ let print_out_string ppf s = else fprintf ppf "%S" s +(* We cannot use the [float32] type in the compiler. *) external float32_format : string -> Obj.t -> string = "caml_format_float32" let float32_to_string f = Stdlib.valid_float_lexem (float32_format "%.9g" f) From dc6e300e9eac4f6df747f4e1e83cfd9cb4de08aa Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Tue, 24 Dec 2024 10:06:20 +0100 Subject: [PATCH 04/30] Fix IRC and Greedy allocators (arm64) (#3388) --- .github/workflows/build.yml | 18 ++++++++++ backend/regalloc/regalloc_gi.ml | 8 +++-- backend/regalloc/regalloc_gi_utils.ml | 6 ++-- backend/regalloc/regalloc_gi_utils.mli | 2 +- backend/regalloc/regalloc_irc.ml | 46 ++++++++++++-------------- 5 files changed, 49 insertions(+), 31 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 642675b0048..95bb2620865 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -78,6 +78,24 @@ jobs: config: --enable-middle-end=flambda2 --disable-warn-error os: macos-latest + - name: flambda2_macos_arm64_irc + config: --enable-middle-end=flambda2 --disable-warn-error + os: macos-latest + build_ocamlparam: '_,w=-46,regalloc=irc' + ocamlparam: '_,w=-46,regalloc=irc' + + - name: flambda2_macos_arm64_ls + config: --enable-middle-end=flambda2 --disable-warn-error + os: macos-latest + build_ocamlparam: '_,w=-46,regalloc=ls' + ocamlparam: '_,w=-46,regalloc=ls' + + - name: flambda2_macos_arm64_gi + config: --enable-middle-end=flambda2 --disable-warn-error + os: macos-latest + build_ocamlparam: '_,w=-46,regalloc=gi' + ocamlparam: '_,w=-46,regalloc=gi' + - name: irc config: --enable-middle-end=flambda2 os: ubuntu-latest diff --git a/backend/regalloc/regalloc_gi.ml b/backend/regalloc/regalloc_gi.ml index 260fcdf9169..c35b1c5a490 100644 --- a/backend/regalloc/regalloc_gi.ml +++ b/backend/regalloc/regalloc_gi.ml @@ -83,13 +83,15 @@ let make_hardware_registers_and_prio_queue (cfg_with_infos : Cfg_with_infos.t) : Reg.Tbl.iter (fun reg interval -> match reg.loc with - | Reg _ -> + | Reg _ -> ( if gi_debug then ( log ~indent:1 "pre-assigned register %a" Printreg.reg reg; log ~indent:2 "%a" Interval.print interval); - let hardware_reg = Hardware_registers.of_reg hardware_registers reg in - Hardware_register.add_non_evictable hardware_reg reg interval + match Hardware_registers.of_reg hardware_registers reg with + | None -> () + | Some hardware_reg -> + Hardware_register.add_non_evictable hardware_reg reg interval) | Unknown -> let priority = priority_heuristics reg interval in if gi_debug diff --git a/backend/regalloc/regalloc_gi_utils.ml b/backend/regalloc/regalloc_gi_utils.ml index e2a146f43a0..5b5dd62d1bc 100644 --- a/backend/regalloc/regalloc_gi_utils.ml +++ b/backend/regalloc/regalloc_gi_utils.ml @@ -596,14 +596,16 @@ module Hardware_registers = struct assigned = [] })) - let of_reg (t : t) (reg : Reg.t) : Hardware_register.t = + let of_reg (t : t) (reg : Reg.t) : Hardware_register.t option = match reg.loc with | Reg reg_index -> let reg_class : int = Proc.register_class reg in let reg_index_in_class : int = reg_index - Proc.first_available_register.(reg_class) in - t.(reg_class).(reg_index_in_class) + if reg_index_in_class < Array.length t.(reg_class) + then Some t.(reg_class).(reg_index_in_class) + else None | Unknown -> fatal "`Unknown` location (expected `Reg _`)" | Stack _ -> fatal "`Stack _` location (expected `Reg _`)" diff --git a/backend/regalloc/regalloc_gi_utils.mli b/backend/regalloc/regalloc_gi_utils.mli index dfa910db19d..11e8c8b6ce1 100644 --- a/backend/regalloc/regalloc_gi_utils.mli +++ b/backend/regalloc/regalloc_gi_utils.mli @@ -190,7 +190,7 @@ module Hardware_registers : sig val make : unit -> t - val of_reg : t -> Reg.t -> Hardware_register.t + val of_reg : t -> Reg.t -> Hardware_register.t option val find_available : t -> Reg.t -> Interval.t -> available end diff --git a/backend/regalloc/regalloc_irc.ml b/backend/regalloc/regalloc_irc.ml index 8f54ecc04ed..fac94b4bd7b 100644 --- a/backend/regalloc/regalloc_irc.ml +++ b/backend/regalloc/regalloc_irc.ml @@ -4,36 +4,32 @@ open! Regalloc_utils open! Regalloc_irc_utils module State = Regalloc_irc_state -(* Remove the frame pointer from the passed array if present, returning the - passed array otherwise *) -let filter_fp : Reg.t array -> Reg.t array = +let filter_unavailable : Reg.t array -> Reg.t array = fun regs -> - let is_fp (reg : Reg.t) : bool = + let is_available (reg : Reg.t) : bool = match reg.loc with - | Unknown -> false + | Unknown -> true | Reg r -> let reg_class = Proc.register_class reg in r - Proc.first_available_register.(reg_class) - >= Proc.num_available_registers.(reg_class) - | Stack _ -> false + < Proc.num_available_registers.(reg_class) + | Stack _ -> true in - let len = Array.length regs in - let idx = ref 0 in - while !idx < len && not (is_fp regs.(!idx)) do - incr idx - done; - if !idx >= len + let num_available = + Array.fold_left regs ~init:0 ~f:(fun acc reg -> + if is_available reg then succ acc else acc) + in + if num_available = Array.length regs then regs - else if len = 1 - then [||] else - let new_regs = Array.make (pred len) regs.(0) in - Array.blit ~src:regs ~src_pos:0 ~dst:new_regs ~dst_pos:0 ~len:!idx; - Array.blit ~src:regs ~src_pos:(succ !idx) ~dst:new_regs ~dst_pos:!idx - ~len:(len - !idx - 1); - new_regs - -let filter_fp regs = if Config.with_frame_pointers then filter_fp regs else regs + let res = Array.make num_available Reg.dummy in + let idx = ref 0 in + Array.iter regs ~f:(fun reg -> + if is_available reg + then ( + res.(!idx) <- reg; + incr idx)); + res let build : State.t -> Cfg_with_infos.t -> unit = fun state cfg_with_infos -> @@ -41,7 +37,7 @@ let build : State.t -> Cfg_with_infos.t -> unit = let liveness = Cfg_with_infos.liveness cfg_with_infos in let add_edges_live (id : Instruction.id) ~(def : Reg.t array) ~(move_src : Reg.t) ~(destroyed : Reg.t array) : unit = - let destroyed = filter_fp destroyed in + let destroyed = filter_unavailable destroyed in let live = Cfg_dataflow.Instr.Tbl.find liveness id in if irc_debug && Reg.set_has_collisions live.across then fatal "live set has physical register collisions"; @@ -91,8 +87,8 @@ let build : State.t -> Cfg_with_infos.t -> unit = let live = Cfg_dataflow.Instr.Tbl.find liveness first_id in Reg.Set.iter (fun reg1 -> - Array.iter (filter_fp Proc.destroyed_at_raise) ~f:(fun reg2 -> - State.add_edge state reg1 reg2)) + Array.iter (filter_unavailable Proc.destroyed_at_raise) + ~f:(fun reg2 -> State.add_edge state reg1 reg2)) (Reg.Set.remove Proc.loc_exn_bucket live.before)) let make_work_list : State.t -> unit = From 2358e099fd9a30be1892d73dc2675f4339f13dd7 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 24 Dec 2024 15:54:06 +0000 Subject: [PATCH 05/30] Upload core files etc upon CI failure (#3405) --- .github/workflows/build.yml | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 95bb2620865..8fb29218912 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -247,11 +247,20 @@ jobs: --with-dune=$GITHUB_WORKSPACE/ocaml-414/_install/bin/dune \ ${{ matrix.config }} + - name: Setup for saving core files (not for macOS at the moment) + if: matrix.os != 'macos-latest' + run: | + sudo mkdir /cores + sudo chmod 777 /cores + # Core filenames will be of the form executable.pid.timestamp: + sudo bash -c 'echo "/cores/%e.%p.%t" > /proc/sys/kernel/core_pattern' + - name: Build, install and test Flambda backend working-directory: flambda_backend run: | if [ $run_testsuite = true ]; then target=ci; else target=compiler; fi export PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH + ulimit -c unlimited make $target \ || (if [ $expected_fail = true ]; then exit 0; else exit 1; fi); env: @@ -265,6 +274,25 @@ jobs: if: matrix.check_arch == true run: | PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH make check_all_arches + + - uses: actions/upload-artifact@v3 + if: ${{ failure() }} && matrix.os != 'macos-latest' + with: + name: cores + path: /cores + + - uses: actions/upload-artifact@v3 + if: ${{ failure() }} && matrix.os != 'macos-latest' + with: + name: _build + path: $GITHUB_WORKSPACE/_build + + - uses: actions/upload-artifact@v3 + if: ${{ failure() }} && matrix.os != 'macos-latest' + with: + name: _runtest + path: $GITHUB_WORKSPACE/_runtest + concurrency: group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} cancel-in-progress: true From 1eeed8761a4bd59778b4f5fe210c0268f1a7299e Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 26 Dec 2024 15:00:49 +0000 Subject: [PATCH 06/30] Revert "Implement %makearray_dynamic{,_uninit}" (#3408) Revert "Implement %makearray_dynamic{,_uninit} (#3317)" This reverts commit 6da1dde0b8a3391d08d5267c2c58654694bda880. --- .github/workflows/build.yml | 4 +- bytecomp/bytegen.ml | 60 +- lambda/lambda.ml | 71 +- lambda/lambda.mli | 27 +- lambda/printlambda.ml | 12 +- lambda/printlambda.mli | 1 - lambda/translprim.ml | 91 +- lambda/translprim.mli | 1 - .../from_lambda/closure_conversion.ml | 21 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 5 +- .../lambda_to_flambda_primitives.ml | 162 +- .../lambda_to_flambda_primitives.mli | 2 - .../lambda_to_lambda_transforms.ml | 451 +- .../lambda_to_lambda_transforms.mli | 3 +- runtime/array.c | 224 +- runtime/caml/custom.h | 7 - runtime/caml/memory.h | 1 - runtime/custom.c | 39 +- runtime/float32.c | 21 +- runtime/memory.c | 14 +- runtime/simd.c | 39 +- runtime4/array.c | 228 +- runtime4/caml/custom.h | 7 - runtime4/caml/memory.h | 1 - runtime4/custom.c | 27 +- runtime4/float32.c | 21 +- runtime4/memory.c | 14 +- runtime4/simd.c | 39 +- .../tests/typing-layouts-arrays/README.md | 34 - .../typing-layouts-arrays/basics_alpha.ml | 299 - .../gen_product_array_helpers.ml | 353 - .../gen_product_array_helpers.mli | 26 - .../generate_makearray_dynamic_tests.ml | 682 -- .../typing-layouts-arrays/generated_test.ml | 8785 ----------------- .../generated_test.reference | 5 - .../run_makearray_dynamic_tests.ml | 24 - .../test_float_u_array.ml | 93 - .../test_ignorable_product_array_1.ml | 93 - .../test_ignorable_product_array_2.ml | 114 - ...t_ignorable_product_array_with_uninit_1.ml | 90 - ...t_ignorable_product_array_with_uninit_2.ml | 111 - .../test_scannable_product_array_1.ml | 94 - .../test_scannable_product_array_2.ml | 116 - .../test_scannable_product_array_3.ml | 96 - .../test_scannable_product_array_4.ml | 100 - .../tests/typing-layouts-products/basics.ml | 27 +- .../typing-layouts-products/product_arrays.ml | 10 +- .../product_iarrays.ml | 2 +- .../basics_from_unboxed_tuples_tests.ml | 8 +- testsuite/tests/typing-layouts/layout_poly.ml | 21 +- typing/primitive.ml | 6 - typing/typeopt.ml | 2 +- 52 files changed, 226 insertions(+), 12558 deletions(-) delete mode 100644 testsuite/tests/typing-layouts-arrays/README.md delete mode 100644 testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli delete mode 100644 testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/generated_test.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/generated_test.reference delete mode 100644 testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_float_u_array.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml delete mode 100644 testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 8fb29218912..c9193354c58 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -127,8 +127,8 @@ jobs: - name: gi config: --enable-middle-end=flambda2 os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1' - ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1' + build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1,vectorize=1' + ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1,vectorize=1' check_arch: true - name: cfg-selection diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 3691b1f0515..3766aa0315d 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -685,10 +685,7 @@ let comp_primitive stack_info p sz args = "Preinterpret_unboxed_int64_as_tagged_int63 can only be used on 64-bit \ targets"; Kccall("caml_reinterpret_unboxed_int64_as_tagged_int63", 1) - | Pmakearray_dynamic(kind, locality, With_initializer) -> - if List.compare_length_with args 2 <> 0 then - fatal_error "Bytegen.comp_primitive: Pmakearray_dynamic takes two \ - arguments for [With_initializer]"; + | Pmakearray_dynamic(kind, locality) -> (* CR layouts v4.0: This is "wrong" for unboxed types. It should construct blocks that can't be marshalled. We've decided to ignore that problem in the short term, as it's unlikely to cause issues - see the internal arrays @@ -704,8 +701,8 @@ let comp_primitive stack_info p sz args = | Alloc_heap -> Kccall("caml_make_vect", 2) | Alloc_local -> Kccall("caml_make_local_vect", 2) end - | Parrayblit { src_mutability = _; dst_array_set_kind } -> - begin match dst_array_set_kind with + | Parrayblit(kind) -> + begin match kind with | Punboxedvectorarray_set _ -> fatal_error "SIMD is not supported in bytecode mode." | Pgenarray_set _ | Pintarray_set | Paddrarray_set _ @@ -713,9 +710,6 @@ let comp_primitive stack_info p sz args = | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _ -> () end; Kccall("caml_array_blit", 5) - | Pmakearray_dynamic(_, _, Uninitialized) -> - Misc.fatal_error "Pmakearray_dynamic Uninitialized should have been \ - translated to Pmakearray_dynamic Initialized earlier on" (* The cases below are handled in [comp_expr] before the [comp_primitive] call (in the order in which they appear below), so they should never be reached in this function. *) @@ -1017,54 +1011,6 @@ and comp_expr stack_info env exp sz cont = (Kreperformterm(sz + nargs) :: discard_dead_code cont) else fatal_error "Reperform used in non-tail position" - | Lprim (Pmakearray_dynamic (kind, locality, Uninitialized), [len], loc) -> - (* Use a dummy initializer to implement the "uninitialized" primitive *) - let init = - match kind with - | Pgenarray | Paddrarray | Pintarray | Pfloatarray - | Pgcscannableproductarray _ -> - Misc.fatal_errorf "Array kind %s should have been ruled out by \ - the frontend for %%makearray_dynamic_uninit" - (Printlambda.array_kind kind) - | Punboxedfloatarray Unboxed_float32 -> - Lconst (Const_base (Const_float32 "0.0")) - | Punboxedfloatarray Unboxed_float64 -> - Lconst (Const_base (Const_float "0.0")) - | Punboxedintarray Unboxed_int32 -> - Lconst (Const_base (Const_int32 0l)) - | Punboxedintarray Unboxed_int64 -> - Lconst (Const_base (Const_int64 0L)) - | Punboxedintarray Unboxed_nativeint -> - Lconst (Const_base (Const_nativeint 0n)) - | Punboxedvectorarray _ -> - fatal_error "SIMD is not supported in bytecode mode." - | Pgcignorableproductarray ignorables -> - let rec convert_ignorable - (ign : Lambda.ignorable_product_element_kind) = - match ign with - | Pint_ignorable -> Lconst (Const_base (Const_int 0)) - | Punboxedfloat_ignorable Unboxed_float32 -> - Lconst (Const_base (Const_float32 "0.0")) - | Punboxedfloat_ignorable Unboxed_float64 -> - Lconst (Const_base (Const_float "0.0")) - | Punboxedint_ignorable Unboxed_int32 -> - Lconst (Const_base (Const_int32 0l)) - | Punboxedint_ignorable Unboxed_int64 -> - Lconst (Const_base (Const_int64 0L)) - | Punboxedint_ignorable Unboxed_nativeint -> - Lconst (Const_base (Const_nativeint 0n)) - | Pproduct_ignorable ignorables -> - let fields = List.map convert_ignorable ignorables in - Lprim (Pmakeblock (0, Immutable, None, alloc_heap), fields, - loc) - in - convert_ignorable (Pproduct_ignorable ignorables) - in - comp_expr stack_info env - (Lprim (Pmakearray_dynamic (kind, locality, With_initializer), - [len; init], loc)) sz cont - | Lprim (Pmakearray_dynamic (_, _, Uninitialized), _, _loc) -> - Misc.fatal_error "Pmakearray_dynamic takes one arg when [Uninitialized]" | Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind',_,m),args,_)], loc) -> assert (kind = kind'); diff --git a/lambda/lambda.ml b/lambda/lambda.ml index d5bc289e09a..a151ee51b1d 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -43,10 +43,6 @@ type field_read_semantics = | Reads_agree | Reads_vary -type has_initializer = - | With_initializer - | Uninitialized - include (struct type locality_mode = @@ -193,12 +189,9 @@ type primitive = | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag * locality_mode - | Pmakearray_dynamic of array_kind * locality_mode * has_initializer + | Pmakearray_dynamic of array_kind * locality_mode | Pduparray of array_kind * mutable_flag - | Parrayblit of { - src_mutability : mutable_flag; - dst_array_set_kind : array_set_kind; - } + | Parrayblit of array_set_kind (* Kind of the dest array. *) | Parraylength of array_kind | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag | Parraysetu of array_set_kind * array_index_kind @@ -951,10 +944,6 @@ let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region = let lambda_unit = Lconst const_unit -let of_bool = function - | true -> Lconst (const_int 1) - | false -> Lconst (const_int 0) - (* CR vlaviron: review the following cases *) let non_null_value raw_kind = Pvalue { raw_kind; nullable = Non_nullable } @@ -1830,7 +1819,7 @@ let primitive_may_allocate : primitive -> locality_mode option = function | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None | Pmakearray (_, _, m) -> Some m - | Pmakearray_dynamic (_, m, _) -> Some m + | Pmakearray_dynamic (_, m) -> Some m | Pduparray _ -> Some alloc_heap | Parraylength _ -> None | Parrayblit _ @@ -2399,21 +2388,6 @@ let array_set_kind mode = function | Pgcscannableproductarray kinds -> Pgcscannableproductarray_set (mode, kinds) | Pgcignorableproductarray kinds -> Pgcignorableproductarray_set kinds -let array_ref_kind_of_array_set_kind (kind : array_set_kind) mode - : array_ref_kind = - match kind with - | Pintarray_set -> Pintarray_ref - | Punboxedfloatarray_set uf -> Punboxedfloatarray_ref uf - | Punboxedintarray_set ui -> Punboxedintarray_ref ui - | Punboxedvectorarray_set uv -> Punboxedvectorarray_ref uv - | Pgcscannableproductarray_set (_, scannables) -> - Pgcscannableproductarray_ref scannables - | Pgcignorableproductarray_set ignorables -> - Pgcignorableproductarray_ref ignorables - | Pgenarray_set _ -> Pgenarray_ref mode - | Paddrarray_set _ -> Paddrarray_ref - | Pfloatarray_set -> Pfloatarray_ref mode - let may_allocate_in_region lam = (* loop_region raises, if the lambda might allocate in parent region *) let rec loop_region lam = @@ -2505,42 +2479,3 @@ let rec try_to_find_location lam = let try_to_find_debuginfo lam = Debuginfo.from_location (try_to_find_location lam) - -let rec count_initializers_scannable - (scannable : scannable_product_element_kind) = - match scannable with - | Pint_scannable | Paddr_scannable -> 1 - | Pproduct_scannable scannables -> - List.fold_left - (fun acc scannable -> acc + count_initializers_scannable scannable) - 0 scannables - -let rec count_initializers_ignorable - (ignorable : ignorable_product_element_kind) = - match ignorable with - | Pint_ignorable | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> 1 - | Pproduct_ignorable ignorables -> - List.fold_left - (fun acc ignorable -> acc + count_initializers_ignorable ignorable) - 0 ignorables - -let count_initializers_array_kind (lambda_array_kind : array_kind) = - match lambda_array_kind with - | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray _ - | Punboxedintarray _ | Punboxedvectorarray _ -> 1 - | Pgcscannableproductarray scannables -> - List.fold_left - (fun acc scannable -> acc + count_initializers_scannable scannable) - 0 scannables - | Pgcignorableproductarray ignorables -> - List.fold_left - (fun acc ignorable -> acc + count_initializers_ignorable ignorable) - 0 ignorables - -let rec ignorable_product_element_kind_involves_int - (kind : ignorable_product_element_kind) = - match kind with - | Pint_ignorable -> true - | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> false - | Pproduct_ignorable kinds -> - List.exists ignorable_product_element_kind_involves_int kinds diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 31a90c4434e..f72780dda1c 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -74,10 +74,6 @@ type field_read_semantics = | Reads_agree | Reads_vary -type has_initializer = - | With_initializer - | Uninitialized - (* Tail calls can close their enclosing region early *) type region_close = | Rc_normal (* do not close region, may TCO if in tail position *) @@ -182,21 +178,15 @@ type primitive = | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag * locality_mode - | Pmakearray_dynamic of array_kind * locality_mode * has_initializer - (** For [Pmakearray_dynamic], if the array kind specifies an unboxed - product, the float array optimization will never apply. *) + | Pmakearray_dynamic of array_kind * locality_mode | Pduparray of array_kind * mutable_flag (** For [Pduparray], the argument must be an immutable array. The arguments of [Pduparray] give the kind and mutability of the array being *produced* by the duplication. *) - | Parrayblit of { - src_mutability : mutable_flag; - dst_array_set_kind : array_set_kind; - } + | Parrayblit of array_set_kind (** For [Parrayblit], we record the [array_set_kind] of the destination array. We check that the source array has the same shape, but do not - need to know anything about its locality. We do however request the - mutability of the source array. *) + need to know anything about its locality. *) | Parraylength of array_kind | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag | Parraysetu of array_set_kind * array_index_kind @@ -924,8 +914,6 @@ val const_unit: structured_constant val const_int : int -> structured_constant val lambda_unit: lambda -val of_bool : bool -> lambda - val layout_unit : layout val layout_int : layout val layout_array : array_kind -> layout @@ -1170,11 +1158,6 @@ val array_ref_kind : locality_mode -> array_kind -> array_ref_kind (** The mode will be discarded if unnecessary for the given [array_kind] *) val array_set_kind : modify_mode -> array_kind -> array_set_kind -(** Any mode information in the given [array_set_kind] is ignored. Any mode - in the return value always comes from the [locality_mode] parameter. *) -val array_ref_kind_of_array_set_kind - : array_set_kind -> locality_mode -> array_ref_kind - (* Returns true if the given lambda can allocate on the local stack *) val may_allocate_in_region : lambda -> bool @@ -1190,7 +1173,3 @@ val try_to_find_location : lambda -> scoped_location val try_to_find_debuginfo : lambda -> Debuginfo.t val primitive_can_raise : primitive -> bool - -val count_initializers_array_kind : array_kind -> int -val ignorable_product_element_kind_involves_int : - ignorable_product_element_kind -> bool diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 74cd27a3e1b..ed0e1326695 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -668,20 +668,14 @@ let primitive ppf = function | Pmakearray (k, Immutable_unique, mode) -> fprintf ppf "make%sarray_unique[%s]" (locality_mode_if_local mode) (array_kind k) - | Pmakearray_dynamic (k, mode, has_init) -> - fprintf ppf "make%sarray_any[%s]%s" (locality_mode_if_local mode) + | Pmakearray_dynamic (k, mode) -> + fprintf ppf "make%sarray_any[%s]" (locality_mode_if_local mode) (array_kind k) - (match has_init with - | With_initializer -> "" - | Uninitialized -> "[uninit]") | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) | Pduparray (k, Immutable_unique) -> fprintf ppf "duparray_unique[%s]" (array_kind k) - | Parrayblit { src_mutability; dst_array_set_kind } -> - fprintf ppf "arrayblit[%s -> %a]" - (array_mut src_mutability) - array_set_kind dst_array_set_kind + | Parrayblit sk -> fprintf ppf "arrayblit[%a]" array_set_kind sk | Parrayrefu (rk, idx, mut) -> fprintf ppf "%s.unsafe_get[%a indexed by %a]" (array_mut mut) array_ref_kind rk diff --git a/lambda/printlambda.mli b/lambda/printlambda.mli index 05bb1f49f1d..fc4b898a224 100644 --- a/lambda/printlambda.mli +++ b/lambda/printlambda.mli @@ -44,7 +44,6 @@ val print_bigarray : val zero_alloc_attribute : formatter -> zero_alloc_attribute -> unit val locality_mode : formatter -> locality_mode -> unit val array_kind : array_kind -> string -val array_set_kind : formatter -> array_set_kind -> unit val tag_and_constructor_shape : (formatter -> value_kind -> unit) -> diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 770a4f8ecc1..109651c043c 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -30,7 +30,6 @@ type error = | Wrong_arity_builtin_primitive of string | Invalid_floatarray_glb | Product_iarrays_unsupported - | Invalid_array_kind_for_uninitialized_makearray_dynamic exception Error of Location.t * error @@ -46,18 +45,6 @@ let unboxed_product_iarray_check loc kind mut = | Punboxedintarray _ | Punboxedvectorarray _), _ -> () -let unboxed_product_uninitialized_array_check loc array_kind = - (* See comments in lambda_to_lambda_transforms.ml in Flambda 2 for more - details on this restriction. *) - match array_kind with - | Pgcignorableproductarray igns - when not (List.exists - Lambda.ignorable_product_element_kind_involves_int igns) -> () - | Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _ -> - () - | Pgenarray | Paddrarray | Pintarray | Pfloatarray - | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> - raise (Error (loc, Invalid_array_kind_for_uninitialized_makearray_dynamic)) (* Insertion of debugging events *) @@ -544,23 +531,11 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_nativeint)), 3) | "%makearray_dynamic" -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; - Primitive (Pmakearray_dynamic (gen_array_kind, mode, With_initializer), 2) - | "%makearray_dynamic_uninit" -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; - Primitive (Pmakearray_dynamic (gen_array_kind, mode, Uninitialized), 1) + Language_extension.assert_enabled ~loc Layouts Language_extension.Alpha; + Primitive (Pmakearray_dynamic (gen_array_kind, mode), 2) | "%arrayblit" -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; - Primitive (Parrayblit { - src_mutability = Mutable; - dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ()) - }, 5); - | "%arrayblit_src_immut" -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; - Primitive (Parrayblit { - src_mutability = Immutable; - dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ()) - }, 5); + Language_extension.assert_enabled ~loc Layouts Language_extension.Alpha; + Primitive (Parrayblit (gen_array_set_kind (get_third_arg_mode ())), 5) | "%obj_size" -> Primitive ((Parraylength Pgenarray), 1) | "%obj_field" -> Primitive ((Parrayrefu (Pgenarray_ref mode, Ptagged_int_index, Mutable)), 2) | "%obj_set_field" -> @@ -1254,40 +1229,19 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = if st = array_set_type then None else Some (Primitive (Parraysets (array_set_type, index_kind), arity)) end - | Primitive (Pmakearray_dynamic (array_kind, mode, With_initializer), 2), - _ :: p2 :: [] -> begin + | Primitive (Pmakearray_dynamic (at, mode), arity), + _ :: p2 :: _ -> begin let loc = to_location loc in - let new_array_kind = - array_kind_of_elt ~elt_sort:None env loc p2 - |> glb_array_type loc array_kind - in - let array_mut = array_type_mut env rest_ty in - unboxed_product_iarray_check loc new_array_kind array_mut; - if array_kind = new_array_kind then None - else - Some (Primitive (Pmakearray_dynamic ( - new_array_kind, mode, With_initializer), 2)) - end - | Primitive (Pmakearray_dynamic (array_kind, mode, Uninitialized), 1), - _ :: [] -> begin - let loc = to_location loc in - let new_array_kind = - array_type_kind ~elt_sort:None env loc rest_ty - |> glb_array_type loc array_kind + let array_type = + glb_array_type loc at + (array_kind_of_elt ~elt_sort:None env loc p2) in let array_mut = array_type_mut env rest_ty in - unboxed_product_iarray_check loc new_array_kind array_mut; - unboxed_product_uninitialized_array_check loc new_array_kind; - if array_kind = new_array_kind then None - else - Some (Primitive (Pmakearray_dynamic ( - new_array_kind, mode, Uninitialized), 1)) + unboxed_product_iarray_check loc array_type array_mut; + if at = array_type then None + else Some (Primitive (Pmakearray_dynamic (array_type, mode), arity)) end - | Primitive (Pmakearray_dynamic _, arity), args -> - Misc.fatal_errorf - "Wrong arity for Pmakearray_dynamic (arity=%d, args length %d)" - arity (List.length args) - | Primitive (Parrayblit { src_mutability; dst_array_set_kind }, arity), + | Primitive (Parrayblit st, arity), _p1 :: _ :: p2 :: _ -> let loc = to_location loc in (* We only use the kind of one of two input arrays here. If you've bound the @@ -1295,13 +1249,11 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = kind. If you haven't, then taking the glb of both would be just as likely to compound your error (e.g., by treating a Pgenarray as a Pfloatarray) as to help you. *) - let array_kind = array_type_kind ~elt_sort:None env loc p2 in - let new_dst_array_set_kind = - glb_array_set_type loc dst_array_set_kind array_kind + let array_type = + glb_array_set_type loc st (array_type_kind ~elt_sort:None env loc p2) in - if dst_array_set_kind = new_dst_array_set_kind then None - else Some (Primitive (Parrayblit { - src_mutability; dst_array_set_kind = new_dst_array_set_kind }, arity)) + if st = array_type then None + else Some (Primitive (Parrayblit array_type, arity)) | Primitive (Pbigarrayref(unsafe, n, kind, layout), arity), p1 :: _ -> begin let (k, l) = bigarray_specialize_kind_and_layout env ~kind ~layout p1 in match k, l with @@ -1781,7 +1733,7 @@ let lambda_primitive_needs_event_after = function | Pmulfloat (_, _) | Pdivfloat (_, _) | Pstringrefs | Pbytesrefs | Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _ - | Pmakearray_dynamic (Pgenarray, _, _) + | Pmakearray_dynamic (Pgenarray, _) | Parrayrefu ((Pgenarray_ref _ | Pfloatarray_ref _), _, _) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ @@ -1831,7 +1783,7 @@ let lambda_primitive_needs_event_after = function | Pmakearray_dynamic ((Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _ - | Pgcscannableproductarray _ | Pgcignorableproductarray _), _, _) + | Pgcscannableproductarray _ | Pgcignorableproductarray _), _) | Parrayblit _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisnull | Pisout | Pprobe_is_enabled _ @@ -1905,11 +1857,6 @@ let report_error ppf = function | Product_iarrays_unsupported -> fprintf ppf "Immutable arrays of unboxed products are not yet supported." - | Invalid_array_kind_for_uninitialized_makearray_dynamic -> - fprintf ppf - "%%makearray_dynamic_uninit can only be used for GC-ignorable arrays@ \ - not involving tagged immediates; and arrays of unboxed numbers.@ Use \ - %%makearray instead, providing an initializer." let () = Location.register_error_of_exn diff --git a/lambda/translprim.mli b/lambda/translprim.mli index 2f58c381370..10916122801 100644 --- a/lambda/translprim.mli +++ b/lambda/translprim.mli @@ -64,7 +64,6 @@ type error = | Wrong_arity_builtin_primitive of string | Invalid_floatarray_glb | Product_iarrays_unsupported - | Invalid_array_kind_for_uninitialized_makearray_dynamic exception Error of Location.t * error diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index eac97e6e665..00f1f447c81 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -993,18 +993,19 @@ let close_primitive acc env ~let_bound_ids_with_kinds named | Pmakearray (array_kind, _, _mode) -> let array_kind = Empty_array_kind.of_lambda array_kind in register_const0 acc (Static_const.empty_array array_kind) "empty_array" + | Pmakearray_dynamic (_array_kind, _mode) -> + Misc.fatal_error "Closure_conversion.close_primitive: unimplemented" | Parrayblit _array_set_kind -> Misc.fatal_error "Closure_conversion.close_primitive: unimplemented" - | Pmakearray_dynamic _ | Pbytes_to_string | Pbytes_of_string - | Parray_of_iarray | Parray_to_iarray | Pignore | Pgetglobal _ - | Psetglobal _ | Pgetpredef _ | Pfield _ | Pfield_computed _ | Psetfield _ - | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ - | Pccall _ | Praise _ | Pufloatfield _ | Psetufloatfield _ | Psequand - | Psequor | Pnot | Pnegint | Pmixedfield _ | Psetmixedfield _ | Paddint - | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints - | Pcompare_floats _ | Pcompare_bints _ | Poffsetint _ | Poffsetref _ - | Pintoffloat _ + | Pbytes_to_string | Pbytes_of_string | Parray_of_iarray + | Parray_to_iarray | Pignore | Pgetglobal _ | Psetglobal _ | Pgetpredef _ + | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ + | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ + | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor | Pnot | Pnegint + | Pmixedfield _ | Psetmixedfield _ | Paddint | Psubint | Pmulint + | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint + | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats _ + | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat _ | Pfloatofint (_, _) | Pfloatoffloat32 _ | Pfloat32offloat _ | Pnegfloat (_, _) diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 80c5b51a1cd..3f232bb6643 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -535,10 +535,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) id, Lprim (prim, args, loc), body ) -> ( - let env, result = - Lambda_to_lambda_transforms.transform_primitive env prim args loc - in - match result with + match Lambda_to_lambda_transforms.transform_primitive env prim args loc with | Primitive (prim, args, loc) -> (* This case avoids extraneous continuations. *) let exn_continuation : IR.exn_continuation option = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index 3cc3cf9d30a..c91ccd3663b 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -814,48 +814,13 @@ let bytes_like_set ~dbg ~unsafe (* Array bounds checks *) -(* The following function constructs bounds checks based on two things: - - 1. The array length kind, which specifies the representation of the array, - including any unboxed product types. This kind is used to establish the - starting field index in the runtime value where the access(es) is/are going - to occur, in addition to how many fields are going to be accessed at a - minimum. "How many fields" is always one except in the case where unboxed - products are involved: in such cases, more than one field may be accessed. - "At a minimum" only applies for vector reinterpret operations as described - next; in all other cases this number is exact. - - 2. The [num_consecutive_elements_being_accessed]. "Elements" here refers to - the non-unarized elements as the user sees via the array get/set primitives. - This value is always 1 except in the case where the array operation is in - fact really a reinterpret operation with a vector input or output (for - example an array of naked floats being read as a 128-bit vector of such - floats). In these latter cases the value of - [num_consecutive_elements_being_accessed] may be greater than 1. This value - may not be greater than 1 if unboxed products are involved, at present. *) - -(* CR mshinwell: When considering vectors and unboxed products, we should think - again about whether the abstractions/concepts here can be improved. *) let multiple_word_array_access_validity_condition array ~size_int - array_length_kind (index_kind : L.array_index_kind) - ~num_consecutive_elements_being_accessed ~index = - let width_in_scalars_per_access = - P.Array_kind_for_length.width_in_scalars array_length_kind - in - assert (width_in_scalars_per_access >= 1); + array_length_kind (index_kind : L.array_index_kind) ~width_in_scalars ~index + = let length_tagged = H.Prim (Unary (Array_length array_length_kind, array)) in - if num_consecutive_elements_being_accessed < 1 - then - Misc.fatal_errorf - "Invalid num_consecutive_elements_being_accessed value: %d" - num_consecutive_elements_being_accessed - else if width_in_scalars_per_access > 1 - && num_consecutive_elements_being_accessed > 1 - then - Misc.fatal_error - "Unboxed product arrays cannot involve vector accesses at present" - else if width_in_scalars_per_access = 1 - && num_consecutive_elements_being_accessed = 1 + if width_in_scalars < 1 + then Misc.fatal_errorf "Invalid width_in_scalars value: %d" width_in_scalars + else if width_in_scalars = 1 then (* Ensure good code generation in the common case. *) check_bound ~index_kind ~bound_kind:Tagged_immediate ~index @@ -863,19 +828,13 @@ let multiple_word_array_access_validity_condition array ~size_int else let length_untagged = untag_int length_tagged in let reduced_length_untagged = - if num_consecutive_elements_being_accessed = 1 - then length_untagged - else - (* This is used for vector accesses, where no unarization is - involved. *) - H.Prim - (Binary - ( Int_arith (Naked_immediate, Sub), - length_untagged, - Simple - (Simple.untagged_const_int - (Targetint_31_63.of_int - (num_consecutive_elements_being_accessed - 1))) )) + H.Prim + (Binary + ( Int_arith (Naked_immediate, Sub), + length_untagged, + Simple + (Simple.untagged_const_int + (Targetint_31_63.of_int (width_in_scalars - 1))) )) in (* We need to convert the length into a naked_nativeint because the optimised version of the max_with_zero function needs to be on @@ -888,21 +847,34 @@ let multiple_word_array_access_validity_condition array ~size_int reduced_length_untagged )) in let nativeint_bound = max_with_zero ~size_int reduced_length_nativeint in - let nativeint_bound : H.simple_or_prim = - if width_in_scalars_per_access = 1 - then nativeint_bound - else - (* This is used for unboxed product accesses. [index] is in non-unarized - terms and we don't touch it, to avoid risks of overflow. Instead we - compute the non-unarized bound, then compare against that. *) - Prim - (Binary - ( Int_arith (Naked_nativeint, Div), - nativeint_bound, - Simple - (Simple.const - (Reg_width_const.naked_nativeint - (Targetint_32_64.of_int width_in_scalars_per_access))) )) + let index : H.simple_or_prim = + (* [length_tagged] is in units of scalars. Multiply up [index] to + match. *) + let multiplier = + P.Array_kind_for_length.width_in_scalars array_length_kind + in + let arith_kind, multiplier = + match index_kind with + | Ptagged_int_index -> + ( I.Tagged_immediate, + Simple.const_int (Targetint_31_63.of_int multiplier) ) + | Punboxed_int_index bint -> ( + match bint with + | Unboxed_int32 -> + ( I.Naked_int32, + Simple.const + (Reg_width_const.naked_int32 (Int32.of_int multiplier)) ) + | Unboxed_int64 -> + ( I.Naked_int64, + Simple.const + (Reg_width_const.naked_int64 (Int64.of_int multiplier)) ) + | Unboxed_nativeint -> + ( I.Naked_nativeint, + Simple.const + (Reg_width_const.naked_nativeint + (Targetint_32_64.of_int multiplier)) )) + in + Prim (Binary (Int_arith (arith_kind, Mul), index, Simple multiplier)) in check_bound ~index_kind ~bound_kind:Naked_nativeint ~index ~bound:nativeint_bound @@ -911,25 +883,25 @@ let multiple_word_array_access_validity_condition array ~size_int (* CR mshinwell: it seems like these could be folded into the normal array load/store functions below *) +let array_vector_access_width_in_scalars (array_kind : P.Array_kind.t) = + match array_kind with + | Naked_vec128s -> 1 + | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2 + | Naked_int32s | Naked_float32s -> 4 + | Values -> + Misc.fatal_error + "Attempted to load/store a SIMD vector from/to a value array." + | Unboxed_product _ -> + (* CR mshinwell: support unboxed products involving vectors? *) + Misc.fatal_error + "Attempted to load/store a SIMD vector from/to an unboxed product array, \ + which is not yet supported." + let array_vector_access_validity_condition array ~size_int (array_kind : P.Array_kind.t) index = - let num_consecutive_elements_being_accessed = - match array_kind with - | Naked_vec128s -> 1 - | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2 - | Naked_int32s | Naked_float32s -> 4 - | Values -> - Misc.fatal_error - "Attempted to load/store a SIMD vector from/to a value array." - | Unboxed_product _ -> - (* CR mshinwell: support unboxed products involving vectors? *) - Misc.fatal_error - "Attempted to load/store a SIMD vector from/to an unboxed product \ - array, which is not yet supported." - in + let width_in_scalars = array_vector_access_width_in_scalars array_kind in multiple_word_array_access_validity_condition array ~size_int - (Array_kind array_kind) Ptagged_int_index - ~num_consecutive_elements_being_accessed ~index + (Array_kind array_kind) Ptagged_int_index ~width_in_scalars ~index let check_array_vector_access ~dbg ~size_int ~array array_kind ~index primitive : H.expr_primitive = @@ -1081,16 +1053,17 @@ let bigarray_set ~dbg ~unsafe kind layout b indexes value = (* Array accesses *) let array_access_validity_condition array array_kind index - ~(index_kind : L.array_index_kind) ~size_int = + ~(index_kind : L.array_index_kind) ~width_in_scalars ~size_int = [ multiple_word_array_access_validity_condition array ~size_int array_kind - index_kind ~num_consecutive_elements_being_accessed:1 ~index ] + index_kind ~width_in_scalars ~index ] let check_array_access ~dbg ~array array_kind ~index ~index_kind ~size_int primitive : H.expr_primitive = + let width_in_scalars = P.Array_kind_for_length.width_in_scalars array_kind in checked_access ~primitive ~conditions: (array_access_validity_condition array array_kind index ~index_kind - ~size_int) + ~width_in_scalars ~size_int) ~dbg let compute_array_indexes ~index ~num_elts = @@ -1217,7 +1190,7 @@ let rec array_set_unsafe dbg ~array ~index array_kind then Misc.fatal_errorf "Wrong arity for unboxed product array_set_unsafe:@ %a" Debuginfo.print_compact dbg; - (* CR mshinwell: should these be set in reverse order, to match the + (* XXX mshinwell: should these be set in reverse order, to match the evaluation order? *) [ H.Sequence (List.concat_map @@ -1458,10 +1431,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) List.map unbox_float args ), Variadic (Make_array (Values, mutability, mode), args), [K.With_subkind.any_value] ) ])) - | Pmakearray_dynamic _, _ | Parrayblit _, _ -> - Misc.fatal_error - "Lambda_to_flambda_primitives.convert_lprim: Pmakearray_dynamic and \ - Parrayblit should have been expanded in [Lambda_to_lambda_transforms]" + | Pmakearray_dynamic (_lambda_array_kind, _mode), _ -> + Misc.fatal_error "Lambda_to_flambda_primitives.convert_lprim: unimplemented" + | Parrayblit _array_set_kind, _ -> + Misc.fatal_error "Lambda_to_flambda_primitives.convert_lprim: unimplemented" | Popaque layout, [arg] -> opaque layout arg ~middle_end_only:false | Pobj_magic layout, [arg] -> opaque layout arg ~middle_end_only:true | Pduprecord (repr, num_fields), [[arg]] -> @@ -1999,8 +1972,6 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [Binary (Int_arith (I.Tagged_immediate, Div), arg1, arg2)] | Pdivint Safe, [[arg1]; [arg2]] -> [checked_arith_op ~dbg None Div None arg1 arg2 ~current_region] - | Pmodint Unsafe, [[arg1]; [arg2]] -> - [H.Binary (Int_arith (I.Tagged_immediate, Mod), arg1, arg2)] | Pmodint Safe, [[arg1]; [arg2]] -> [checked_arith_op ~dbg None Mod None arg1 arg2 ~current_region] | Pdivbint { size = Boxed_int32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> @@ -2370,7 +2341,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) "Preinterpret_tagged_int63_as_unboxed_int64 can only be used on 64-bit \ targets"; [Unary (Reinterpret_64_bit_word Tagged_int63_as_unboxed_int64, i)] - | ( ( Pdivbint { is_safe = Unsafe; size = _; mode = _ } + | ( ( Pmodint Unsafe + | Pdivbint { is_safe = Unsafe; size = _; mode = _ } | Pmodbint { is_safe = Unsafe; size = _; mode = _ } | Psetglobal _ | Praise _ | Pccall _ ), _ ) -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli index 70cbfc63835..c678ffe5494 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli @@ -17,8 +17,6 @@ module Acc = Closure_conversion_aux.Acc module Expr_with_acc = Closure_conversion_aux.Expr_with_acc -val check_float_array_optimisation_enabled : string -> unit - val convert_and_bind : Acc.t -> big_endian:bool -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml index 8545b061d90..7886600e567 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml @@ -110,447 +110,7 @@ let rec_catch_for_for_loop env loc ident start stop in env, lam -type initialize_array_element_width = - | Thirty_two of { zero_init : L.lambda } - | Sixty_four_or_more - -let initialize_array0 env loc ~length array_set_kind width ~(init : L.lambda) - creation_expr = - let array = Ident.create_local "array" in - (* If the element size is 32-bit, zero-initialize the last 64-bit word, to - ensure reproducibility. *) - (* CR mshinwell: why does e.g. caml_make_unboxed_int32_vect not do this? *) - let maybe_zero_init_last_field = - match width with - | Sixty_four_or_more -> L.lambda_unit - | Thirty_two { zero_init } -> - let zero_init_last_field = - L.Lprim - ( Parraysetu (array_set_kind, Ptagged_int_index), - (* [Popaque] is used to conceal the out-of-bounds write. *) - [Lprim (Popaque L.layout_unit, [Lvar array], loc); length; zero_init], - loc ) - in - let length_is_greater_than_zero_and_is_one_mod_two = - L.Lprim - ( Psequand, - [ Lprim (Pintcomp Cgt, [Lconst (L.const_int 0); length], loc); - Lprim - ( Pintcomp Cne, - [ Lprim (Pmodint Unsafe, [length; Lconst (L.const_int 2)], loc); - Lconst (L.const_int 0) ], - loc ) ], - loc ) - in - L.Lifthenelse - ( length_is_greater_than_zero_and_is_one_mod_two, - zero_init_last_field, - L.lambda_unit, - L.layout_unit ) - in - let env, initialize = - let index = Ident.create_local "index" in - rec_catch_for_for_loop env loc index - (Lconst (L.const_int 0)) - (L.Lprim (Psubint, [length; Lconst (L.const_int 1)], loc)) - Upto - (Lprim - ( Parraysetu (array_set_kind, Ptagged_int_index), - [Lvar array; Lvar index; init], - loc )) - in - let term = - L.Llet - ( Strict, - Pvalue { raw_kind = Pgenval; nullable = Non_nullable }, - array, - creation_expr, - Lsequence - (maybe_zero_init_last_field, Lsequence (initialize, Lvar array)) ) - in - env, Transformed term - -let initialize_array env loc ~length array_set_kind width ~init creation_expr = - match init with - | None -> env, Transformed creation_expr - | Some init -> - initialize_array0 env loc ~length array_set_kind width ~init creation_expr - -let makearray_dynamic_singleton name (mode : L.locality_mode) ~length ~init loc - = - let name = - Printf.sprintf "caml_make%s_%s%svect" - (match mode with Alloc_heap -> "" | Alloc_local -> "_local") - name - (if String.length name > 0 then "_" else "") - in - let external_call_desc = - Primitive.make ~name ~alloc:true (* the C stub may raise an exception *) - ~c_builtin:false ~effects:Arbitrary_effects ~coeffects:Has_coeffects - ~native_name:name - ~native_repr_args: - ([Primitive.Prim_global, L.Same_as_ocaml_repr (Base Value)] - @ - match init with - | None -> [] - | Some (init_extern_repr, _) -> [Primitive.Prim_local, init_extern_repr] - ) - ~native_repr_res: - ( (match mode with - | Alloc_heap -> Prim_global - | Alloc_local -> Prim_local), - L.Same_as_ocaml_repr (Base Value) ) - ~is_layout_poly:false - in - L.Lprim - ( Pccall external_call_desc, - ([length] @ match init with None -> [] | Some (_, init) -> [init]), - loc ) - -let makearray_dynamic_singleton_uninitialized name (mode : L.locality_mode) - ~length loc = - makearray_dynamic_singleton name - (mode : L.locality_mode) - ~length ~init:None loc - -let makearray_dynamic_unboxed_products_only_64_bit () = - (* To keep things simple in the C stub as regards array length, we currently - restrict to 64-bit targets. *) - if not (Target_system.is_64_bit ()) - then - Misc.fatal_error - "Cannot compile Pmakearray_dynamic at unboxed product layouts for 32-bit \ - targets" - -let makearray_dynamic_unboxed_product_c_stub ~name (mode : L.locality_mode) = - Primitive.make ~name ~alloc:true (* the C stub may raise an exception *) - ~c_builtin:false ~effects:Arbitrary_effects ~coeffects:Has_coeffects - ~native_name:name - ~native_repr_args: - [ Prim_global, L.Same_as_ocaml_repr (Base Value); - Prim_local, L.Same_as_ocaml_repr (Base Value); - Prim_global, L.Same_as_ocaml_repr (Base Value) ] - ~native_repr_res: - ( (match mode with Alloc_heap -> Prim_global | Alloc_local -> Prim_local), - L.Same_as_ocaml_repr (Base Value) ) - ~is_layout_poly:false - -let makearray_dynamic_non_scannable_unboxed_product env - (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length - ~(init : L.lambda option) loc = - makearray_dynamic_unboxed_products_only_64_bit (); - let is_local = - L.of_bool (match mode with Alloc_heap -> false | Alloc_local -> true) - in - let external_call_desc = - makearray_dynamic_unboxed_product_c_stub - ~name:"caml_makearray_dynamic_non_scannable_unboxed_product" mode - in - let num_components = L.count_initializers_array_kind lambda_array_kind in - (* Note that we don't check the number of unarized arguments against the - layout; we trust the front end. If we wanted to do this, it would have to - be done slightly later, after unarization. *) - (* CR mshinwell: two things were tried here, but one is dirty and the other - needed too much work: - - - CPS convert the primitive arguments before getting here. They may then - have to be converted a second time, in the event that the primitive is - transformed by this file. - - - For this primitive only, have a function passed in here which when - called, does the CPS conversion of the arguments and then escapes using an - exception, returning the number of arguments. This seems dirty. - - Both of these cases introduce complexity as it is necessary to go back to - using an older accumulator during CPS conversion. This is probably fine but - is a real change. *) - let term = - L.( - Lprim - ( Pccall external_call_desc, - [Lconst (L.const_int num_components); is_local; length], - loc )) - in - match init with - | None -> env, Transformed term - | Some init -> - initialize_array0 env loc ~length - (L.array_set_kind - (match mode with - | Alloc_heap -> L.modify_heap - | Alloc_local -> L.modify_maybe_stack) - lambda_array_kind) - (* There is no packing in unboxed product arrays, even if the elements are - all float32# or int32#. *) - Sixty_four_or_more ~init term - -let makearray_dynamic_scannable_unboxed_product0 - (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length ~init - loc = - makearray_dynamic_unboxed_products_only_64_bit (); - (* Trick: use the local stack as a way of getting the variable argument list - to the C function. *) - if not Config.stack_allocation - then - Misc.fatal_error - "Cannot compile Pmakearray_dynamic at unboxed product layouts without \ - stack allocation enabled"; - let args_array = Ident.create_local "args_array" in - let array_layout = L.layout_array lambda_array_kind in - let is_local = - L.of_bool (match mode with Alloc_heap -> false | Alloc_local -> true) - in - let external_call_desc = - makearray_dynamic_unboxed_product_c_stub - ~name:"caml_makearray_dynamic_scannable_unboxed_product" mode - in - (* Note that we don't check the number of unarized arguments against the - layout; we trust the front end. If we wanted to do this, it would have to - be done slightly later, after unarization. *) - let body = - L.Llet - ( Strict, - array_layout, - args_array, - Lprim - ( Pmakearray (lambda_array_kind, Immutable, L.alloc_local), - [init] (* will be unarized when this term is CPS converted *), - loc ), - Lprim - (Pccall external_call_desc, [Lvar args_array; is_local; length], loc) - ) - in - (* We must not add a region if the C stub is going to return a local value, - otherwise we will incorrectly close the region on such live value. *) - Transformed - (match mode with - | Alloc_local -> body - | Alloc_heap -> L.Lregion (body, array_layout)) - -let makearray_dynamic_scannable_unboxed_product env - (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length - ~(init : L.lambda) loc = - let must_be_scanned = - match lambda_array_kind with - | Pgcignorableproductarray _ -> false - | Pgcscannableproductarray kinds -> - let rec must_be_scanned (kind : L.scannable_product_element_kind) = - match kind with - | Pint_scannable -> false - | Paddr_scannable -> true - | Pproduct_scannable kinds -> List.exists must_be_scanned kinds - in - List.exists must_be_scanned kinds - | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray _ - | Punboxedintarray _ | Punboxedvectorarray _ -> - Misc.fatal_errorf - "%s: should have been sent to [makearray_dynamic_singleton]" - (Printlambda.array_kind lambda_array_kind) - in - if must_be_scanned - then - ( env, - makearray_dynamic_scannable_unboxed_product0 lambda_array_kind mode - ~length ~init loc ) - else - makearray_dynamic_non_scannable_unboxed_product env lambda_array_kind mode - ~length ~init:(Some init) loc - -let makearray_dynamic env (lambda_array_kind : L.array_kind) - (mode : L.locality_mode) (has_init : L.has_initializer) args loc : - Env.t * primitive_transform_result = - (* %makearray_dynamic is analogous to (from stdlib/array.ml): - * external create: int -> 'a -> 'a array = "caml_make_vect" - * except that it works on any layout, including unboxed products, at both - * heap and local modes. - * Additionally, if the initializer is omitted, an uninitialized array will - * be returned. Initializers must however be provided when the array kind is - * Pgenarray, Paddrarray, Pintarray, Pfloatarray or Pgcscannableproductarray; - * or when a Pgcignorablearray involves an [int]. (See comment below.) - *) - let dbg = Debuginfo.from_location loc in - let length, init = - match args, has_init with - | [length], Uninitialized -> length, None - | [length; init], With_initializer -> length, Some init - | _, (Uninitialized | With_initializer) -> - Misc.fatal_errorf - "Pmakearray_dynamic takes the (non-unarized) length and optionally an \ - initializer (the latter perhaps of unboxed product layout) according \ - to the setting of [Uninitialized] or [With_initializer]:@ %a" - Debuginfo.print_compact dbg - in - let[@inline] must_have_initializer () = - match init with - | Some init -> init - | None -> ( - match lambda_array_kind with - | Pintarray | Pgcignorableproductarray _ -> - (* If we get here for [Pgcignorableproductarray] then a tagged immediate - is involved: see main [match] below. *) - Misc.fatal_errorf - "Cannot compile Pmakearray_dynamic at layout %s without an \ - initializer; otherwise it might be possible for values of type \ - [int] having incorrect representations to be revealed, thus \ - breaking soundness:@ %a" - (Printlambda.array_kind lambda_array_kind) - Debuginfo.print_compact dbg - | Pgenarray | Paddrarray | Pfloatarray | Punboxedfloatarray _ - | Punboxedintarray _ | Punboxedvectorarray _ | Pgcscannableproductarray _ - -> - Misc.fatal_errorf - "Cannot compile Pmakearray_dynamic at layout %s without an \ - initializer:@ %a" - (Printlambda.array_kind lambda_array_kind) - Debuginfo.print_compact dbg) - in - match lambda_array_kind with - | Pgenarray | Paddrarray | Pintarray | Pfloatarray -> - let init = must_have_initializer () in - ( env, - Transformed - (makearray_dynamic_singleton "" mode ~length - ~init:(Some (Same_as_ocaml_repr (Base Value), init)) - loc) ) - | Punboxedfloatarray Unboxed_float32 -> - makearray_dynamic_singleton_uninitialized "unboxed_float32" ~length mode loc - |> initialize_array env loc ~length (Punboxedfloatarray_set Unboxed_float32) - (Thirty_two - { zero_init = Lconst (Const_base (Const_unboxed_float32 "0")) }) - ~init - | Punboxedfloatarray Unboxed_float64 -> - makearray_dynamic_singleton_uninitialized "unboxed_float64" ~length mode loc - |> initialize_array env loc ~length (Punboxedfloatarray_set Unboxed_float64) - Sixty_four_or_more ~init - | Punboxedintarray Unboxed_int32 -> - makearray_dynamic_singleton_uninitialized "unboxed_int32" ~length mode loc - |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_int32) - (Thirty_two - { zero_init = Lconst (Const_base (Const_unboxed_int32 0l)) }) - ~init - | Punboxedintarray Unboxed_int64 -> - makearray_dynamic_singleton_uninitialized "unboxed_int64" ~length mode loc - |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_int64) - Sixty_four_or_more ~init - | Punboxedintarray Unboxed_nativeint -> - makearray_dynamic_singleton_uninitialized "unboxed_nativeint" ~length mode - loc - |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_nativeint) - Sixty_four_or_more ~init - | Punboxedvectorarray Unboxed_vec128 -> - makearray_dynamic_singleton_uninitialized "unboxed_vec128" ~length mode loc - |> initialize_array env loc ~length (Punboxedvectorarray_set Unboxed_vec128) - Sixty_four_or_more ~init - | Pgcscannableproductarray _ -> - let init = must_have_initializer () in - makearray_dynamic_scannable_unboxed_product env lambda_array_kind mode - ~length ~init loc - | Pgcignorableproductarray ignorable -> - (* Care: all (unarized) elements that are valid OCaml values, in this case - of type [int] or equivalent, must be initialized. This is to ensure - soundness in the event of a read occurring prior to initialization (e.g. - by ensuring that values without the bottom bit set cannot be returned at - type [int]). *) - let init = - if List.exists L.ignorable_product_element_kind_involves_int ignorable - then Some (must_have_initializer ()) - else init - in - makearray_dynamic_non_scannable_unboxed_product env lambda_array_kind mode - ~length ~init loc - -let arrayblit env ~(src_mutability : L.mutable_flag) - ~(dst_array_set_kind : L.array_set_kind) args loc = - let src_array_ref_kind = - (* We don't expect any allocation (e.g. occurring from the reading of a - [float array]) to persist after simplification. We use [alloc_local] just - in case that simplification doesn't happen for some reason (this seems - unlikely). *) - L.array_ref_kind_of_array_set_kind dst_array_set_kind L.alloc_local - in - match args with - | [src_expr; src_start_pos_expr; dst_expr; dst_start_pos_expr; length_expr] -> - (* Care: the [args] are arbitrary Lambda expressions, so need to be - [let]-bound *) - let id = Ident.create_local in - let bind = L.bind_with_layout in - let src = id "src" in - let src_start_pos = id "src_start_pos" in - let dst = id "dst" in - let dst_start_pos = id "dst_start_pos" in - let length = id "length" in - (* CR mshinwell: support indexing by other types apart from [int] *) - let src_end_pos_exclusive = - L.Lprim (Paddint, [Lvar src_start_pos; Lvar length], loc) - in - let src_end_pos_inclusive = - L.Lprim (Psubint, [src_end_pos_exclusive; Lconst (L.const_int 1)], loc) - in - let dst_start_pos_minus_src_start_pos = - L.Lprim (Psubint, [Lvar dst_start_pos; Lvar src_start_pos], loc) - in - let dst_start_pos_minus_src_start_pos_var = - Ident.create_local "dst_start_pos_minus_src_start_pos" - in - let must_copy_backwards = - L.Lprim (Pintcomp Cgt, [Lvar dst_start_pos; Lvar src_start_pos], loc) - in - let make_loop env (direction : Asttypes.direction_flag) = - let src_index = Ident.create_local "index" in - let start_pos, end_pos = - match direction with - | Upto -> L.Lvar src_start_pos, src_end_pos_inclusive - | Downto -> src_end_pos_inclusive, L.Lvar src_start_pos - in - rec_catch_for_for_loop env loc src_index start_pos end_pos direction - (Lprim - ( Parraysetu (dst_array_set_kind, Ptagged_int_index), - [ Lvar dst; - Lprim - ( Paddint, - [Lvar src_index; dst_start_pos_minus_src_start_pos], - loc ); - Lprim - ( Parrayrefu - ( src_array_ref_kind, - Ptagged_int_index, - match src_mutability with - | Immutable | Immutable_unique -> Immutable - | Mutable -> Mutable ), - [Lvar src; Lvar src_index], - loc ) ], - loc )) - in - let env, copy_backwards = make_loop env Downto in - let env, copy_forwards = make_loop env Upto in - let body = - (* The region is expected to be redundant (see comment above about - modes). *) - L.Lregion - ( L.Lifthenelse - (must_copy_backwards, copy_backwards, copy_forwards, L.layout_unit), - L.layout_unit ) - in - let expr = - (* Preserve right-to-left evaluation order. *) - bind Strict (length, L.layout_int) length_expr - @@ bind Strict (dst_start_pos, L.layout_int) dst_start_pos_expr - @@ bind Strict (dst, L.layout_any_value) dst_expr - @@ bind Strict (src_start_pos, L.layout_int) src_start_pos_expr - @@ bind Strict (src, L.layout_any_value) src_expr - @@ bind Strict - (dst_start_pos_minus_src_start_pos_var, L.layout_int) - dst_start_pos_minus_src_start_pos body - in - env, Transformed expr - | _ -> - Misc.fatal_errorf - "Wrong arity for Parrayblit{,_immut} (expected src, src_offset, \ - dst_offset and length):@ %a" - Debuginfo.print_compact - (Debuginfo.from_location loc) - -let transform_primitive0 env (prim : L.primitive) args loc = +let transform_primitive env (prim : L.primitive) args loc = match prim, args with | Psequor, [arg1; arg2] -> let const_true = Ident.create_local "const_true" in @@ -691,12 +251,3 @@ let transform_primitive0 env (prim : L.primitive) args loc = (see translprim).") | _, _ -> Primitive (prim, args, loc) [@@ocaml.warning "-fragile-match"] - -let transform_primitive env (prim : L.primitive) args loc = - match prim with - | Pmakearray_dynamic (lambda_array_kind, mode, has_init) -> - makearray_dynamic env lambda_array_kind mode has_init args loc - | Parrayblit { src_mutability; dst_array_set_kind } -> - arrayblit env ~src_mutability ~dst_array_set_kind args loc - | _ -> env, transform_primitive0 env prim args loc - [@@ocaml.warning "-fragile-match"] diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli index 4ea169908bb..f7a0bd73d04 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli @@ -44,7 +44,6 @@ val switch_for_if_then_else : val transform_primitive : Lambda_to_flambda_env.t -> Lambda.primitive -> - (* CR mshinwell: consider [Ident.t list] instead for the arguments. *) Lambda.lambda list -> Lambda.scoped_location -> - Lambda_to_flambda_env.t * primitive_transform_result + primitive_transform_result diff --git a/runtime/array.c b/runtime/array.c index 419645d85db..a58b16c1cc7 100644 --- a/runtime/array.c +++ b/runtime/array.c @@ -406,18 +406,6 @@ CAMLprim value caml_floatarray_create_local(value len) return caml_alloc_local (wosize, Double_array_tag); } -// Stubs with consistent naming: - -CAMLprim value caml_make_unboxed_float64_vect(value len) -{ - return caml_floatarray_create(len); -} - -CAMLprim value caml_make_local_unboxed_float64_vect(value len) -{ - return caml_floatarray_create_local(len); -} - /* [len] is a [value] representing number of words or floats */ static value make_vect_gen(value len, value init, int local) { @@ -465,8 +453,7 @@ static value make_vect_gen(value len, value init, int local) for (i = 0; i < size; i++) Field(res, i) = init; } } - /* Give the GC a chance to run, and run memprof callbacks. - This matches the semantics of allocations directly from OCaml code. */ + /* Give the GC a chance to run, and run memprof callbacks */ if (!local) caml_process_pending_actions (); CAMLreturn (res); } @@ -482,151 +469,6 @@ CAMLprim value caml_make_local_vect(value len, value init) return make_vect_gen(len, init, 1); } -CAMLprim value caml_makearray_dynamic_non_scannable_unboxed_product( - value v_num_components, value v_is_local, - value v_non_unarized_length) -{ - // Some of this is similar to [caml_make_vect], above. - // This function is only used for native code. - - CAMLparam0(); - CAMLlocal1(res); - - mlsize_t num_components = Long_val(v_num_components); - int is_local = Bool_val(v_is_local); - mlsize_t non_unarized_length = Long_val(v_non_unarized_length); - mlsize_t size; - - if (sizeof(uintnat) != sizeof(double)) { - // Just make things easy as regards maximum array lengths for now. - // This should have been caught in [Lambda_to_flambda]. - caml_invalid_argument( - "%makearray_dynamic: only supported on 64-bit targets " - "(this is a compiler bug)"); - } - - int tag = 0; - // These arrays are always mixed blocks without packing. - // This currently differs from e.g. int32# array, which is allocated as a - // custom block, and is packed. - int reserved = Reserved_mixed_block_scannable_wosize_native(0); - - size = non_unarized_length * num_components; - if (size == 0) { - res = Atom(0); - } else if (num_components < 1) { - // This could happen with void layouts. We don't rule it out in - // [Lambda_to_flambda] since it is in fact ok, if the size is zero. - caml_invalid_argument( - "%makearray_dynamic: the only array that can be initialized with " - "nothing is a zero-length array"); - } else if (size > Max_array_wosize) { - caml_invalid_argument( - "%makearray_dynamic: array size too large (> Max_array_wosize)"); - } else if (is_local) { - res = caml_alloc_local_reserved(size, tag, reserved); - } else if (size <= Max_young_wosize) { - res = caml_alloc_small_with_reserved(size, tag, reserved); - } else { - res = caml_alloc_shr_reserved(size, tag, reserved); - } - - /* Give the GC a chance to run, and run memprof callbacks. - This matches the semantics of allocations directly from OCaml code. */ - // CR mshinwell: the other functions which allocate unboxed number arrays - // should also do this - if (!is_local) caml_process_pending_actions (); - - CAMLreturn(res); -} - -CAMLprim value caml_makearray_dynamic_scannable_unboxed_product( - value v_init, value v_is_local, value v_non_unarized_length) -{ - // Some of this is similar to [caml_make_vect], above. - - CAMLparam1(v_init); - CAMLlocal1(res); - - mlsize_t num_initializers = Wosize_val(v_init); - int is_local = Bool_val(v_is_local); - mlsize_t non_unarized_length = Long_val(v_non_unarized_length); - - mlsize_t size, i; - - // N.B. [v_init] may be on the local stack! - - if (sizeof(uintnat) != sizeof(double)) { - // Just make things easy as regards maximum array lengths for now. - // This should have been caught in [Lambda_to_flambda]. - caml_invalid_argument( - "%makearray_dynamic: only supported on 64-bit targets " - "(this is a compiler bug)"); - } - - int tag = 0; - - size = non_unarized_length * num_initializers; - if (size == 0) { - res = Atom(0); - } else if (num_initializers < 1) { - // This could happen with void layouts. We don't rule it out in - // [Lambda_to_flambda] since it is in fact ok, if the size is zero. - caml_invalid_argument( - "%makearray_dynamic: the only array that can be initialized with " - "nothing is a zero-length array"); - } else if (size > Max_array_wosize) { - caml_invalid_argument( - "%makearray_dynamic: array size too large (> Max_array_wosize)"); - } else if (is_local) { - res = caml_alloc_local(size, tag); - for (i = 0; i < size; i++) { - Field(res, i) = Field(v_init, i % num_initializers); - } - } else if (size <= Max_young_wosize) { - res = caml_alloc_small(size, tag); - for (i = 0; i < size; i++) { - Field(res, i) = Field(v_init, i % num_initializers); - } - } else { - int move_init_to_major = 0; - for (mlsize_t i = 0; i < num_initializers; i++) { - if (Is_block(Field(v_init, i)) && Is_young(Field(v_init, i))) { - move_init_to_major = 1; - } - } - if (move_init_to_major) { - /* We don't want to create so many major-to-minor references, - so the contents of [v_init] are moved to the major heap by doing - a minor GC. */ - /* CR mslater/mshinwell: Why is this better than adding them to the - remembered set with caml_initialize? See discussion in a - conversation on: - https://github.com/ocaml-flambda/flambda-backend/pull/3317 - */ - CAML_EV_COUNTER (EV_C_FORCE_MINOR_MAKE_VECT, 1); - caml_minor_collection (); - } -#ifdef DEBUG - for (mlsize_t i = 0; i < num_initializers; i++) { - CAMLassert(!(Is_block(Field(v_init, i)) && Is_young(Field(v_init, i)))); - } -#endif - res = caml_alloc_shr(size, tag); - /* We now know that everything in [v_init] is not in the minor heap, so - there is no need to call [caml_initialize]. */ - for (i = 0; i < size; i++) { - Field(res, i) = Field(v_init, i % num_initializers); - } - } - - /* Give the GC a chance to run, and run memprof callbacks. - This matches the semantics of allocations directly from OCaml code. */ - if (!is_local) caml_process_pending_actions (); - - CAMLreturn(res); -} - /* [len] is a [value] representing number of floats */ /* [ int -> float array ] */ CAMLprim value caml_make_float_vect(value len) @@ -650,34 +492,18 @@ CAMLprim value caml_make_float_vect(value len) #endif } -static value caml_make_unboxed_int32_vect0(value len, int local) +CAMLprim value caml_make_unboxed_int32_vect(value len) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int32_array_wosize) - caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int32_array_wosize) caml_invalid_argument("Array.make"); /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - struct custom_operations* ops = - &caml_unboxed_int32_array_ops[num_elements % 2]; - - if (local) - return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_int32_vect(value len) -{ - return caml_make_unboxed_int32_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_int32_vect(value len) -{ - return caml_make_unboxed_int32_vect0(len, 1); + return caml_alloc_custom(&caml_unboxed_int32_array_ops[num_elements % 2], + num_fields * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) @@ -685,28 +511,14 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int32(0)); } -static value caml_make_unboxed_int64_vect0(value len, int local) +CAMLprim value caml_make_unboxed_int64_vect(value len) { mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int64_array_wosize) - caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int64_array_wosize) caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_int64_array_ops; - if (local) - return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_int64_vect(value len) -{ - return caml_make_unboxed_int64_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_int64_vect(value len) -{ - return caml_make_unboxed_int64_vect0(len, 1); + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) @@ -714,30 +526,16 @@ CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int64(0)); } -static value caml_make_unboxed_nativeint_vect0(value len, int local) +CAMLprim value caml_make_unboxed_nativeint_vect(value len) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_nativeint_array_wosize) - caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_nativeint_array_wosize) caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_nativeint_array_ops; - if (local) - return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_nativeint_vect(value len) -{ - return caml_make_unboxed_nativeint_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_nativeint_vect(value len) -{ - return caml_make_unboxed_nativeint_vect0(len, 1); + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_nativeint_vect_bytecode(value len) diff --git a/runtime/caml/custom.h b/runtime/caml/custom.h index 509a85d2034..127d8247abd 100644 --- a/runtime/caml/custom.h +++ b/runtime/caml/custom.h @@ -59,13 +59,6 @@ CAMLextern value caml_alloc_custom(const struct custom_operations * ops, mlsize_t mem, /*resources consumed*/ mlsize_t max /*max resources*/); -// The local version will fail if a finalizer is supplied in the [ops], -// since finalizers on locally-allocated values are not yet supported. -CAMLextern value caml_alloc_custom_local(const struct custom_operations * ops, - uintnat size, /*size in bytes*/ - mlsize_t mem, /*resources consumed*/ - mlsize_t max /*max resources*/); - /* [caml_alloc_custom_mem] allocates a custom block with dependent memory (memory outside the heap that will be reclaimed when the block is finalized). If [mem] is greater than [custom_minor_max_size] (see gc.mli) diff --git a/runtime/caml/memory.h b/runtime/caml/memory.h index 793aed1a28b..7c3359b7e86 100644 --- a/runtime/caml/memory.h +++ b/runtime/caml/memory.h @@ -37,7 +37,6 @@ CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); CAMLextern value caml_alloc_shr_noexc(mlsize_t wosize, tag_t); CAMLextern value caml_alloc_shr_reserved (mlsize_t, tag_t, reserved_t); CAMLextern value caml_alloc_local(mlsize_t, tag_t); -CAMLextern value caml_alloc_local_reserved(mlsize_t, tag_t, reserved_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_adjust_minor_gc_speed (mlsize_t, mlsize_t); diff --git a/runtime/custom.c b/runtime/custom.c index d277740df05..80f1191c08f 100644 --- a/runtime/custom.c +++ b/runtime/custom.c @@ -67,20 +67,14 @@ static value alloc_custom_gen (const struct custom_operations * ops, mlsize_t mem, mlsize_t max_major, mlsize_t max_minor, - int minor_ok, - int local) + int minor_ok) { mlsize_t wosize; CAMLparam0(); CAMLlocal1(result); wosize = 1 + (bsz + sizeof(value) - 1) / sizeof(value); - if (local) { - CAMLassert(ops->finalize == NULL); - result = caml_alloc_local(wosize, Custom_tag); - Custom_ops_val(result) = ops; - } - else if (wosize <= Max_young_wosize && minor_ok) { + if (wosize <= Max_young_wosize && minor_ok) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; if (ops->finalize != NULL || mem != 0) { @@ -108,35 +102,14 @@ Caml_inline mlsize_t get_max_minor (void) Bsize_wsize (Caml_state->minor_heap_wsz) / 100 * caml_custom_minor_ratio; } -static value caml_alloc_custom0(const struct custom_operations * ops, - uintnat bsz, - mlsize_t mem, - mlsize_t max, - int local) -{ - mlsize_t max_major = max; - mlsize_t max_minor = max == 0 ? get_max_minor() : max; - return alloc_custom_gen (ops, bsz, mem, max_major, max_minor, 1, local); -} - CAMLexport value caml_alloc_custom(const struct custom_operations * ops, uintnat bsz, mlsize_t mem, mlsize_t max) { - return caml_alloc_custom0(ops, bsz, mem, max, 0); -} - -CAMLexport value caml_alloc_custom_local(const struct custom_operations * ops, - uintnat bsz, - mlsize_t mem, - mlsize_t max) -{ - if (ops->finalize != NULL) - caml_invalid_argument( - "caml_alloc_custom_local: finalizers not supported"); - - return caml_alloc_custom0(ops, bsz, mem, max, 1); + mlsize_t max_major = max; + mlsize_t max_minor = max == 0 ? get_max_minor() : max; + return alloc_custom_gen (ops, bsz, mem, max_major, max_minor, 1); } CAMLexport value caml_alloc_custom_mem(const struct custom_operations * ops, @@ -151,7 +124,7 @@ CAMLexport value caml_alloc_custom_mem(const struct custom_operations * ops, max_minor_single = max_minor * caml_custom_minor_max_bsz / 100; } value v = alloc_custom_gen (ops, bsz, mem, 0, - max_minor, (mem < max_minor_single), 0); + max_minor, (mem < max_minor_single)); size_t mem_words = (mem + sizeof(value) - 1) / sizeof(value); caml_memprof_sample_block(v, mem_words, mem_words, CAML_MEMPROF_SRC_CUSTOM); return v; diff --git a/runtime/float32.c b/runtime/float32.c index 6c4cce4cc7a..ca518ecb840 100644 --- a/runtime/float32.c +++ b/runtime/float32.c @@ -853,7 +853,7 @@ CAMLexport const struct custom_operations caml_unboxed_float32_array_ops[2] = { custom_fixed_length_default }, }; -static value caml_make_unboxed_float32_vect0(value len, int local) +CAMLprim value caml_make_unboxed_float32_vect(value len) { /* This is only used on 64-bit targets. */ @@ -863,23 +863,8 @@ static value caml_make_unboxed_float32_vect0(value len, int local) /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - const struct custom_operations* ops = - &caml_unboxed_float32_array_ops[num_elements % 2]; - - if (local) - return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_float32_vect(value len) -{ - return caml_make_unboxed_float32_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_float32_vect(value len) -{ - return caml_make_unboxed_float32_vect0(len, 1); + return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], + num_fields * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) diff --git a/runtime/memory.c b/runtime/memory.c index f867a21a779..fade3ec6c55 100644 --- a/runtime/memory.c +++ b/runtime/memory.c @@ -531,8 +531,7 @@ void caml_local_realloc(void) CAMLassert(Caml_state->local_limit <= Caml_state->local_sp); } -CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, - reserved_t reserved) +CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) { #if defined(NATIVE_CODE) && defined(STACK_ALLOCATION) intnat sp = Caml_state->local_sp; @@ -542,26 +541,21 @@ CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, if (sp < Caml_state->local_limit) caml_local_realloc(); hp = (header_t*)((char*)Caml_state->local_top + sp); - *hp = Make_header_with_reserved(wosize, tag, NOT_MARKABLE, reserved); + *hp = Make_header(wosize, tag, NOT_MARKABLE); return Val_hp(hp); #else if (wosize <= Max_young_wosize) { - return caml_alloc_small_with_reserved(wosize, tag, reserved); + return caml_alloc_small(wosize, tag); } else { /* The return value is initialised directly using Field. This is invalid if it may create major -> minor pointers. So, perform a minor GC to prevent this. (See caml_make_vect) */ caml_minor_collection(); - return caml_alloc_shr_reserved(wosize, tag, reserved); + return caml_alloc_shr(wosize, tag); } #endif } -CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) -{ - return caml_alloc_local_reserved(wosize, tag, 0); -} - CAMLprim value caml_local_stack_offset(value blk) { #ifdef NATIVE_CODE diff --git a/runtime/simd.c b/runtime/simd.c index 3188184ef68..0e1e6129f26 100644 --- a/runtime/simd.c +++ b/runtime/simd.c @@ -75,37 +75,20 @@ CAMLprim value caml_unboxed_vec128_vect_blit(value a1, value ofs1, value a2, return Val_unit; } -static value caml_make_unboxed_vec128_vect0(value len, int local) -{ - /* This is only used on 64-bit targets. */ - - mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_vec128_array_wosize) - caml_invalid_argument("Array.make"); - - /* [num_fields] does not include the custom operations field. */ - mlsize_t num_fields = num_elements * 2; - - if (local) - return caml_alloc_custom_local(&caml_unboxed_vec128_array_ops, - num_fields * sizeof(value), 0, 0); - else - return caml_alloc_custom(&caml_unboxed_vec128_array_ops, - num_fields * sizeof(value), 0, 0); -} +CAMLprim value caml_make_unboxed_vec128_vect(value len) { + /* This is only used on 64-bit targets. */ -CAMLprim value caml_make_unboxed_vec128_vect(value len) -{ - return caml_make_unboxed_vec128_vect0(len, 0); -} + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_unboxed_vec128_array_wosize) caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = num_elements * 2; -CAMLprim value caml_make_local_unboxed_vec128_vect(value len) -{ - return caml_make_unboxed_vec128_vect0(len, 1); + return caml_alloc_custom(&caml_unboxed_vec128_array_ops, num_fields * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { - caml_failwith("SIMD is not supported on this platform."); + caml_failwith("SIMD is not supported in bytecode mode."); } #else @@ -119,10 +102,6 @@ CAMLprim value caml_make_unboxed_vec128_vect(value len) { caml_failwith("SIMD is not supported on this platform."); } -CAMLprim value caml_make_local_unboxed_vec128_vect(value len) { - caml_failwith("SIMD is not supported on this platform."); -} - CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { caml_failwith("SIMD is not supported on this platform."); } diff --git a/runtime4/array.c b/runtime4/array.c index 2d2d67e8f09..ae3306028f6 100644 --- a/runtime4/array.c +++ b/runtime4/array.c @@ -414,18 +414,6 @@ CAMLprim value caml_floatarray_create_local(value len) return caml_alloc_local (wosize, Double_array_tag); } -// Stubs with consistent naming: - -CAMLprim value caml_make_unboxed_float64_vect(value len) -{ - return caml_floatarray_create(len); -} - -CAMLprim value caml_make_local_unboxed_float64_vect(value len) -{ - return caml_floatarray_create_local(len); -} - /* [len] is a [value] representing number of words or floats */ static value make_vect_gen(value len, value init, int local) { @@ -474,12 +462,12 @@ static value make_vect_gen(value len, value init, int local) for (i = 0; i < size; i++) Field(res, i) = init; } } - /* Give the GC a chance to run, and run memprof callbacks. - This matches the semantics of allocations directly from OCaml code. */ + // Give the GC a chance to run, and run memprof callbacks if (!local) caml_process_pending_actions (); CAMLreturn (res); } + CAMLprim value caml_make_vect(value len, value init) { return make_vect_gen(len, init, 0); @@ -490,151 +478,6 @@ CAMLprim value caml_make_local_vect(value len, value init) return make_vect_gen(len, init, 1); } -CAMLprim value caml_makearray_dynamic_non_scannable_unboxed_product( - value v_num_components, value v_is_local, - value v_non_unarized_length) -{ - // Some of this is similar to [caml_make_vect], above. - // This function is only used for native code. - - CAMLparam0(); - CAMLlocal1(res); - - mlsize_t num_components = Long_val(v_num_components); - int is_local = Bool_val(v_is_local); - mlsize_t non_unarized_length = Long_val(v_non_unarized_length); - mlsize_t size; - - if (sizeof(uintnat) != sizeof(double)) { - // Just make things easy as regards maximum array lengths for now. - // This should have been caught in [Lambda_to_flambda]. - caml_invalid_argument( - "%makearray_dynamic: only supported on 64-bit targets " - "(this is a compiler bug)"); - } - - int tag = 0; - // These arrays are always mixed blocks without packing. - // This currently differs from e.g. int32# array, which is allocated as a - // custom block, and is packed. - int reserved = Reserved_mixed_block_scannable_wosize_native(0); - - size = non_unarized_length * num_components; - if (size == 0) { - res = Atom(0); - } else if (num_components < 1) { - // This could happen with void layouts. We don't rule it out in - // [Lambda_to_flambda] since it is in fact ok, if the size is zero. - caml_invalid_argument( - "%makearray_dynamic: the only array that can be initialized with " - "nothing is a zero-length array"); - } else if (size > Max_array_wosize) { - caml_invalid_argument( - "%makearray_dynamic: array size too large (> Max_array_wosize)"); - } else if (is_local) { - res = caml_alloc_local_reserved(size, tag, reserved); - } else if (size <= Max_young_wosize) { - res = caml_alloc_small_with_reserved(size, tag, reserved); - } else { - res = caml_alloc_shr_reserved(size, tag, reserved); - } - - /* Give the GC a chance to run, and run memprof callbacks. - This matches the semantics of allocations directly from OCaml code. */ - // CR mshinwell: the other functions which allocate unboxed number arrays - // should also do this - if (!is_local) caml_process_pending_actions (); - - CAMLreturn(res); -} - -CAMLprim value caml_makearray_dynamic_scannable_unboxed_product( - value v_init, value v_is_local, value v_non_unarized_length) -{ - // Some of this is similar to [caml_make_vect], above. - - CAMLparam1(v_init); - CAMLlocal1(res); - - mlsize_t num_initializers = Wosize_val(v_init); - int is_local = Bool_val(v_is_local); - mlsize_t non_unarized_length = Long_val(v_non_unarized_length); - - mlsize_t size, i; - - // N.B. [v_init] may be on the local stack! - - if (sizeof(uintnat) != sizeof(double)) { - // Just make things easy as regards maximum array lengths for now. - // This should have been caught in [Lambda_to_flambda]. - caml_invalid_argument( - "%makearray_dynamic: only supported on 64-bit targets " - "(this is a compiler bug)"); - } - - int tag = 0; - - size = non_unarized_length * num_initializers; - if (size == 0) { - res = Atom(0); - } else if (num_initializers < 1) { - // This could happen with void layouts. We don't rule it out in - // [Lambda_to_flambda] since it is in fact ok, if the size is zero. - caml_invalid_argument( - "%makearray_dynamic: the only array that can be initialized with " - "nothing is a zero-length array"); - } else if (size > Max_array_wosize) { - caml_invalid_argument( - "%makearray_dynamic: array size too large (> Max_array_wosize)"); - } else if (is_local) { - res = caml_alloc_local(size, tag); - for (i = 0; i < size; i++) { - Field(res, i) = Field(v_init, i % num_initializers); - } - } else if (size <= Max_young_wosize) { - res = caml_alloc_small(size, tag); - for (i = 0; i < size; i++) { - Field(res, i) = Field(v_init, i % num_initializers); - } - } else { - int move_init_to_major = 0; - for (mlsize_t i = 0; i < num_initializers; i++) { - if (Is_block(Field(v_init, i)) && Is_young(Field(v_init, i))) { - move_init_to_major = 1; - } - } - if (move_init_to_major) { - /* We don't want to create so many major-to-minor references, - so the contents of [v_init] are moved to the major heap by doing - a minor GC. */ - /* CR mslater/mshinwell: Why is this better than adding them to the - remembered set with caml_initialize? See discussion in a - conversation on: - https://github.com/ocaml-flambda/flambda-backend/pull/3317 - */ - CAML_EV_COUNTER (EV_C_FORCE_MINOR_MAKE_VECT, 1); - caml_minor_collection (); - } -#ifdef DEBUG - for (mlsize_t i = 0; i < num_initializers; i++) { - CAMLassert(!(Is_block(Field(v_init, i)) && Is_young(Field(v_init, i)))); - } -#endif - res = caml_alloc_shr(size, tag); - /* We now know that everything in [v_init] is not in the minor heap, so - there is no need to call [caml_initialize]. */ - for (i = 0; i < size; i++) { - Field(res, i) = Field(v_init, i % num_initializers); - } - } - - /* Give the GC a chance to run, and run memprof callbacks. - This matches the semantics of allocations directly from OCaml code. */ - if (!is_local) caml_process_pending_actions (); - - CAMLreturn(res); -} - /* [len] is a [value] representing number of floats */ /* [ int -> float array ] */ CAMLprim value caml_make_float_vect(value len) @@ -651,34 +494,18 @@ CAMLprim value caml_make_float_vect(value len) #endif } -static value caml_make_unboxed_int32_vect0(value len, int local) +CAMLprim value caml_make_unboxed_int32_vect(value len) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int32_array_wosize) - caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int32_array_wosize) caml_invalid_argument("Array.make"); /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - struct custom_operations* ops = - &caml_unboxed_int32_array_ops[num_elements % 2]; - - if (local) - return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_int32_vect(value len) -{ - return caml_make_unboxed_int32_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_int32_vect(value len) -{ - return caml_make_unboxed_int32_vect0(len, 1); + return caml_alloc_custom(&caml_unboxed_int32_array_ops[num_elements % 2], + num_fields * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) @@ -686,28 +513,14 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int32(0)); } -static value caml_make_unboxed_int64_vect0(value len, int local) +CAMLprim value caml_make_unboxed_int64_vect(value len) { mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int64_array_wosize) - caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int64_array_wosize) caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_int64_array_ops; - if (local) - return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_int64_vect(value len) -{ - return caml_make_unboxed_int64_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_int64_vect(value len) -{ - return caml_make_unboxed_int64_vect0(len, 1); + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) @@ -715,30 +528,16 @@ CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int64(0)); } -static value caml_make_unboxed_nativeint_vect0(value len, int local) +CAMLprim value caml_make_unboxed_nativeint_vect(value len) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_nativeint_array_wosize) - caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_nativeint_array_wosize) caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_nativeint_array_ops; - if (local) - return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_nativeint_vect(value len) -{ - return caml_make_unboxed_nativeint_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_nativeint_vect(value len) -{ - return caml_make_unboxed_nativeint_vect0(len, 1); + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_nativeint_vect_bytecode(value len) @@ -1164,6 +963,3 @@ CAMLprim value caml_array_unsafe_set_indexed_by_nativeint(value, value, value); Array_access_index_by(int64, int64_t, Int64_val) Array_access_index_by(int32, int32_t, Int32_val) Array_access_index_by(nativeint, intnat, Nativeint_val) - -// XXX mshinwell: add the %makearray_dynamic prims here for runtime4 -// once the runtime5 versions have been reviewed and tested diff --git a/runtime4/caml/custom.h b/runtime4/caml/custom.h index c319276c3f7..62dec5c6302 100644 --- a/runtime4/caml/custom.h +++ b/runtime4/caml/custom.h @@ -61,13 +61,6 @@ CAMLextern value caml_alloc_custom(struct custom_operations * ops, mlsize_t mem, /*resources consumed*/ mlsize_t max /*max resources*/); -// The local version will fail if a finalizer is supplied in the [ops], -// since finalizers on locally-allocated values are not yet supported. -CAMLextern value caml_alloc_custom_local(struct custom_operations * ops, - uintnat size, /*size in bytes*/ - mlsize_t mem, /*resources consumed*/ - mlsize_t max /*max resources*/); - CAMLextern value caml_alloc_custom_mem(struct custom_operations * ops, uintnat size, /*size in bytes*/ mlsize_t mem /*memory consumed*/); diff --git a/runtime4/caml/memory.h b/runtime4/caml/memory.h index d5c70413cbd..e5204f92f96 100644 --- a/runtime4/caml/memory.h +++ b/runtime4/caml/memory.h @@ -55,7 +55,6 @@ CAMLextern value caml_alloc_shr_no_track_noexc (mlsize_t, tag_t); CAMLextern value caml_alloc_shr_for_minor_gc (mlsize_t, tag_t, header_t); CAMLextern value caml_alloc_local(mlsize_t, tag_t); -CAMLextern value caml_alloc_local_reserved(mlsize_t, tag_t, reserved_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); diff --git a/runtime4/custom.c b/runtime4/custom.c index 48595a91518..37d88f48cdc 100644 --- a/runtime4/custom.c +++ b/runtime4/custom.c @@ -35,8 +35,7 @@ static value alloc_custom_gen (struct custom_operations * ops, mlsize_t mem, mlsize_t max_major, mlsize_t mem_minor, - mlsize_t max_minor, - int local) + mlsize_t max_minor) { mlsize_t wosize; CAMLparam0(); @@ -47,12 +46,7 @@ static value alloc_custom_gen (struct custom_operations * ops, CAMLassert (mem_minor <= mem); wosize = 1 + (bsz + sizeof(value) - 1) / sizeof(value); - if (local) { - CAMLassert(ops->finalize == NULL); - result = caml_alloc_local(wosize, Custom_tag); - Custom_ops_val(result) = ops; - } - else if (wosize <= Max_young_wosize) { + if (wosize <= Max_young_wosize) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; if (ops->finalize != NULL || mem != 0) { @@ -87,19 +81,7 @@ CAMLexport value caml_alloc_custom(struct custom_operations * ops, mlsize_t mem, mlsize_t max) { - return alloc_custom_gen (ops, bsz, mem, max, mem, max, 0); -} - -CAMLexport value caml_alloc_custom_local(struct custom_operations * ops, - uintnat bsz, - mlsize_t mem, - mlsize_t max) -{ - if (ops->finalize != NULL) - caml_invalid_argument( - "caml_alloc_custom_local: finalizers not supported"); - - return alloc_custom_gen (ops, bsz, mem, max, mem, max, 1); + return alloc_custom_gen (ops, bsz, mem, max, mem, max); } CAMLexport value caml_alloc_custom_mem(struct custom_operations * ops, @@ -121,8 +103,7 @@ CAMLexport value caml_alloc_custom_mem(struct custom_operations * ops, Bsize_wsize (Caml_state->stat_heap_wsz) / 150 * caml_custom_major_ratio; mlsize_t max_minor = Bsize_wsize (Caml_state->minor_heap_wsz) / 100 * caml_custom_minor_ratio; - value v = - alloc_custom_gen (ops, bsz, mem, max_major, mem_minor, max_minor, 0); + value v = alloc_custom_gen (ops, bsz, mem, max_major, mem_minor, max_minor); caml_memprof_track_custom(v, mem); return v; } diff --git a/runtime4/float32.c b/runtime4/float32.c index 5261e191efe..aa046e9e865 100644 --- a/runtime4/float32.c +++ b/runtime4/float32.c @@ -852,7 +852,7 @@ CAMLexport struct custom_operations caml_unboxed_float32_array_ops[2] = { custom_fixed_length_default }, }; -static value caml_make_unboxed_float32_vect0(value len, int local) +CAMLprim value caml_make_unboxed_float32_vect(value len) { /* This is only used on 64-bit targets. */ @@ -862,23 +862,8 @@ static value caml_make_unboxed_float32_vect0(value len, int local) /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - struct custom_operations* ops = - &caml_unboxed_float32_array_ops[num_elements % 2]; - - if (local) - return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); - else - return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); -} - -CAMLprim value caml_make_unboxed_float32_vect(value len) -{ - return caml_make_unboxed_float32_vect0(len, 0); -} - -CAMLprim value caml_make_local_unboxed_float32_vect(value len) -{ - return caml_make_unboxed_float32_vect0(len, 1); + return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], + num_fields * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) diff --git a/runtime4/memory.c b/runtime4/memory.c index 195e98c7877..1d2081d0bfb 100644 --- a/runtime4/memory.c +++ b/runtime4/memory.c @@ -798,8 +798,7 @@ void caml_local_realloc(void) CAMLassert(Caml_state->local_limit <= Caml_state->local_sp); } -CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, - reserved_t reserved) +CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) { #if defined(NATIVE_CODE) && defined(STACK_ALLOCATION) intnat sp = Caml_state->local_sp; @@ -809,26 +808,21 @@ CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, if (sp < Caml_state->local_limit) caml_local_realloc(); hp = (header_t*)((char*)Caml_state->local_top + sp); - *hp = Make_header_with_profinfo(wosize, tag, Local_unmarked, reserved); + *hp = Make_header(wosize, tag, Local_unmarked); return Val_hp(hp); #else if (wosize <= Max_young_wosize) { - return caml_alloc_small_with_reserved(wosize, tag, reserved); + return caml_alloc_small(wosize, tag); } else { /* The return value is initialised directly using Field. This is invalid if it may create major -> minor pointers. So, perform a minor GC to prevent this. (See caml_make_vect) */ caml_minor_collection(); - return caml_alloc_shr_reserved(wosize, tag, reserved); + return caml_alloc_shr(wosize, tag); } #endif } -CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) -{ - return caml_alloc_local_reserved(wosize, tag, 0); -} - CAMLprim value caml_local_stack_offset(value blk) { #ifdef NATIVE_CODE diff --git a/runtime4/simd.c b/runtime4/simd.c index 48986e06b2b..a9ae173772b 100644 --- a/runtime4/simd.c +++ b/runtime4/simd.c @@ -73,37 +73,20 @@ CAMLprim value caml_unboxed_vec128_vect_blit(value a1, value ofs1, value a2, return Val_unit; } -static value caml_make_unboxed_vec128_vect0(value len, int local) -{ - /* This is only used on 64-bit targets. */ - - mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_vec128_array_wosize) - caml_invalid_argument("Array.make"); - - /* [num_fields] does not include the custom operations field. */ - mlsize_t num_fields = num_elements * 2; - - if (local) - return caml_alloc_custom_local(&caml_unboxed_vec128_array_ops, - num_fields * sizeof(value), 0, 0); - else - return caml_alloc_custom(&caml_unboxed_vec128_array_ops, - num_fields * sizeof(value), 0, 0); -} +CAMLprim value caml_make_unboxed_vec128_vect(value len) { + /* This is only used on 64-bit targets. */ -CAMLprim value caml_make_unboxed_vec128_vect(value len) -{ - return caml_make_unboxed_vec128_vect0(len, 0); -} + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_unboxed_vec128_array_wosize) caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = num_elements * 2; -CAMLprim value caml_make_local_unboxed_vec128_vect(value len) -{ - return caml_make_unboxed_vec128_vect0(len, 1); + return caml_alloc_custom(&caml_unboxed_vec128_array_ops, num_fields * sizeof(value), 0, 0); } CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { - caml_failwith("SIMD is not supported on this platform."); + caml_failwith("SIMD is not supported in bytecode mode."); } #else @@ -117,10 +100,6 @@ CAMLprim value caml_make_unboxed_vec128_vect(value len) { caml_failwith("SIMD is not supported on this platform."); } -CAMLprim value caml_make_local_unboxed_vec128_vect(value len) { - caml_failwith("SIMD is not supported on this platform."); -} - CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { caml_failwith("SIMD is not supported on this platform."); } diff --git a/testsuite/tests/typing-layouts-arrays/README.md b/testsuite/tests/typing-layouts-arrays/README.md deleted file mode 100644 index 14c5a717d58..00000000000 --- a/testsuite/tests/typing-layouts-arrays/README.md +++ /dev/null @@ -1,34 +0,0 @@ -This directory has tests for arrays of unboxed types. The tests assume the array -contains something that is like a number. - -Using the test framework here still involves a fair amount of copy and paste to -build your new test. This is mainly because we don't have layout polymorphism, -so it's not really possible to build it as one nice big functor. Hopefully we -can improve it in the future. - -## Basic use - -The files `gen_u_array.ml` and `test_gen_u_array.ml` contain the basic -framework. Rather than reading them, you are probably better off looking at an -example. E.g., see `test_int64_u_array.ml`. - -## Errors - -The testing framework is not very helpful in the event of errors - you'll get an -assertion failure with an uninformative backtrace. One way to debug is to -copy the framework and your test file elsewhere, compile and run it as a normal -ocaml program, then comment out parts of the big test functor from -`test_gen_u_array.ml` until you locate the line causing the error. This should -be improved. - -## Unboxed products - -The file `gen_product_array_helpers.ml` has additional infrastructure for -testing arrays of unboxed products. To add a new test, copy one of the existing -ones (e.g., `test_ignorable_product_array_1.ml`) and follow the instructions -in its comments about which parts you need to edit. - -Note that tests whose filename contains `with_uninit` use -`%makearray_dynamic_uninit` to create arrays, while other tests using this -infrastructure use `%makearray_dynamic`. - diff --git a/testsuite/tests/typing-layouts-arrays/basics_alpha.ml b/testsuite/tests/typing-layouts-arrays/basics_alpha.ml index b52edd91f95..4b6074016e1 100644 --- a/testsuite/tests/typing-layouts-arrays/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-arrays/basics_alpha.ml @@ -362,302 +362,3 @@ Error: This expression has type "float32#" because it's the type of an array element, chosen to have layout value. |}] - -(* Test 8: makearraydynamic_uninit *) - -external[@layout_poly] makearray_dynamic_uninit_local - : ('a : any_non_null) . int -> 'a array @ local = "%makearray_dynamic_uninit" - -external[@layout_poly] makearray_dynamic_uninit - : ('a : any_non_null) . int -> 'a array = "%makearray_dynamic_uninit" -[%%expect{| -external makearray_dynamic_uninit_local : - ('a : any_non_null). int -> local_ 'a array = "%makearray_dynamic_uninit" - [@@layout_poly] -external makearray_dynamic_uninit : ('a : any_non_null). int -> 'a array - = "%makearray_dynamic_uninit" [@@layout_poly] -|}] - -type ('a : any) with_i64s = #( int64# * 'a * int64# ) - -type ok_1 = #(int64# * int32#) -type ok_2 = float# with_i64s - -type bad_1 = #(int * int32#) -type bad_2 = int -type bad_3 = A | B | C -type bad_4 = #{ a: int64# ; enum : bad_3 } -type bad_5 = bad_3 with_i64s -type bad_6 = #(float * #(float * float) * #(float * #(float * float * float))) -type bad_7 = #{ i : int64# ; bad_4 : bad_4 ; j : int64# } -[%%expect{| -type ('a : any) with_i64s = #(int64# * 'a * int64#) -type ok_1 = #(int64# * int32#) -type ok_2 = float# with_i64s -type bad_1 = #(int * int32#) -type bad_2 = int -type bad_3 = A | B | C -type bad_4 = #{ a : int64#; enum : bad_3; } -type bad_5 = bad_3 with_i64s -type bad_6 = - #(float * #(float * float) * #(float * #(float * float * float))) -type bad_7 = #{ i : int64#; bad_4 : bad_4; j : int64#; } -|}] - -(* Allowed usages *) - -let _ = - (makearray_dynamic_uninit 0 : float# array) -[%%expect{| -- : float# array = [||] -|}] - -let _ = - (makearray_dynamic_uninit 0 : ok_1 array) -[%%expect{| -- : ok_1 array = [||] -|}] - -let _ = - (makearray_dynamic_uninit 0 : ok_2 array) -[%%expect{| -- : ok_2 array = [||] -|}] - -(* Disallowed usages *) - -let _ = - (makearray_dynamic_uninit 0 : int array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : int array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : float array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : float array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : #(int64# * int) array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : #(int64# * int) array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : bad_1 array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : bad_1 array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : bad_2 array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : bad_2 array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : bad_3 array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : bad_3 array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : bad_4 array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : bad_4 array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : bad_5 array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : bad_5 array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : bad_6 array) -[%%expect{| -Line 2, characters 2-28: -2 | (makearray_dynamic_uninit 0 : bad_6 array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - (makearray_dynamic_uninit 0 : bad_7 array) -[%%expect{| -Line 2, characters 3-29: -2 | (makearray_dynamic_uninit 0 : bad_7 array) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -(* Allowed usages (local) *) - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : ok_1 array) in - () -[%%expect{| -- : unit = () -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : ok_2 array) in - () -[%%expect{| -- : unit = () -|}] - -(* Disallowed usages (local) *) - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : int array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : int array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : #(int64# * int) array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : #(int64# * int) array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : bad_1 array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : bad_1 array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : bad_2 array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : bad_2 array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : bad_3 array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : bad_3 array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : bad_4 array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : bad_4 array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : bad_5 array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : bad_5 array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : bad_6 array) in - () -[%%expect{| -Line 2, characters 10-42: -2 | let _ = (makearray_dynamic_uninit_local 0 : bad_6 array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] - -let _ = - let _ = (makearray_dynamic_uninit_local 0 : bad_7 array) in - () -[%%expect{| -Line 2, characters 11-43: -2 | let _ = (makearray_dynamic_uninit_local 0 : bad_7 array) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays - not involving tagged immediates; and arrays of unboxed numbers. - Use %makearray instead, providing an initializer. -|}] diff --git a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml deleted file mode 100644 index 296563970a0..00000000000 --- a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml +++ /dev/null @@ -1,353 +0,0 @@ -module type Element_intf = Test_gen_u_array.Element_intf - -type 'a elem = - | Number : { ops : (module Element_intf with type t = 'a) } -> 'a elem - | Option : 'a elem -> ('a option) elem - | Tup2 : 'a1 elem * 'a2 elem -> ('a1 * 'a2) elem - | Tup3 : 'a1 elem * 'a2 elem * 'a3 elem -> ('a1 * 'a2 * 'a3) elem - | Tup4 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem - -> ('a1 * 'a2 * 'a3 * 'a4) elem - | Tup5 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem - -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) elem - | Tup6 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem * 'a6 elem - -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) elem - -module Int_elem : Element_intf with type t = int = -struct - include Int - let of_int x = x - let max_val = max_int - let min_val = min_int - let rand = Random.full_int - let print i = Printf.printf "%d" i -end - -let int_elem = Number { ops = (module Int_elem) } - -module Int32_elem : Element_intf with type t = int32 = -struct - include Int32 - let max_val = max_int - let min_val = min_int - let rand = Random.int32 - let print i = Printf.printf "%ld" i -end - -let int32_elem = Number { ops = (module Int32_elem) } - -module Int64_elem : Element_intf with type t = int64 = -struct - include Int64 - let max_val = max_int - let min_val = min_int - let rand = Random.int64 - let print i = Printf.printf "%Ld" i -end - -let int64_elem = Number { ops = (module Int64_elem) } - -module Nativeint_elem : Element_intf with type t = nativeint = -struct - include Nativeint - let max_val = max_int - let min_val = min_int - let rand = Random.nativeint - let print i = Printf.printf "%nd" i -end - -let nativeint_elem = Number { ops = (module Nativeint_elem) } - -module Float_elem : Element_intf with type t = float = -struct - include Float - let max_val = max_float - let min_val = min_float - let rand = Random.float - let print i = Printf.printf "%f" i -end - -let float_elem = Number { ops = (module Float_elem) } - -module Float32_elem : Element_intf with type t = float32 = -struct - include Stdlib_stable.Float32 - let max_val = max_float - let min_val = min_float - let rand x = of_float (Random.float (to_float x)) - let print i = Printf.printf "%f" (to_float i) -end - -let float32_elem = Number { ops = (module Float32_elem) } - -let traverse0 (f : 'a. (module Element_intf with type t = 'a) -> 'a) = - let rec go : type a . a elem -> a = - fun (elem : a elem) -> - match elem with - | Number {ops} -> f ops - | Option elem -> Some (go elem) - | Tup2 (e1, e2) -> (go e1, go e2) - | Tup3 (e1, e2, e3) -> (go e1, go e2, go e3) - | Tup4 (e1, e2, e3, e4) -> (go e1, go e2, go e3, go e4) - | Tup5 (e1, e2, e3, e4, e5) -> (go e1, go e2, go e3, go e4, go e5) - | Tup6 (e1, e2, e3, e4, e5, e6) -> - (go e1, go e2, go e3, go e4, go e5, go e6) - in - go - -let traverse1 (f : 'a. (module Element_intf with type t = 'a) -> 'a -> 'a) = - let rec go : type a . a elem -> a -> a = - fun (elem : a elem) (a : a) -> - match elem with - | Number {ops} -> f ops a - | Option elem -> Option.map (go elem) a - | Tup2 (e1, e2) -> - let a1, a2 = a in - (go e1 a1, go e2 a2) - | Tup3 (e1, e2, e3) -> - let a1, a2, a3 = a in - (go e1 a1, go e2 a2, go e3 a3) - | Tup4 (e1, e2, e3, e4) -> - let a1, a2, a3, a4 = a in - (go e1 a1, go e2 a2, go e3 a3, go e4 a4) - | Tup5 (e1, e2, e3, e4, e5) -> - let a1, a2, a3, a4, a5 = a in - (go e1 a1, go e2 a2, go e3 a3, go e4 a4, go e5 a5) - | Tup6 (e1, e2, e3, e4, e5, e6) -> - let a1, a2, a3, a4, a5, a6 = a in - (go e1 a1, go e2 a2, go e3 a3, go e4 a4, go e5 a5, go e6 a6) - in - go - -let traverse2 - (f : 'a. (module Element_intf with type t = 'a) -> 'a -> 'a -> 'a) = - let rec go : type a . a elem -> a -> a -> a = - fun (elem : a elem) (a1 : a) (a2 : a) -> - match elem with - | Number {ops} -> f ops a1 a2 - | Option elem -> - begin match a1, a2 with - | None, _ | _, None -> None - | Some a1, Some a2 -> Some (go elem a1 a2) - end - | Tup2 (e1, e2) -> - let a11, a12 = a1 in - let a21, a22 = a2 in - (go e1 a11 a21, go e2 a12 a22) - | Tup3 (e1, e2, e3) -> - let a11, a12, a13 = a1 in - let a21, a22, a23 = a2 in - (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23) - | Tup4 (e1, e2, e3, e4) -> - let a11, a12, a13, a14 = a1 in - let a21, a22, a23, a24 = a2 in - (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24) - | Tup5 (e1, e2, e3, e4, e5) -> - let a11, a12, a13, a14, a15 = a1 in - let a21, a22, a23, a24, a25 = a2 in - (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24, - go e5 a15 a25) - | Tup6 (e1, e2, e3, e4, e5, e6) -> - let a11, a12, a13, a14, a15, a16 = a1 in - let a21, a22, a23, a24, a25, a26 = a2 in - (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24, - go e5 a15 a25, go e6 a16 a26) - in - go - -let rec of_int : type a . a elem -> int -> a = - fun elem i -> - match elem with - | Number {ops} -> - let module O = (val ops) in - O.of_int i - | Option elem -> Some (of_int elem i) - | Tup2 (e1, e2) -> (of_int e1 i, of_int e2 i) - | Tup3 (e1, e2, e3) -> (of_int e1 i, of_int e2 i, of_int e3 i) - | Tup4 (e1, e2, e3, e4) -> - (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i) - | Tup5 (e1, e2, e3, e4, e5) -> - (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i, of_int e5 i) - | Tup6 (e1, e2, e3, e4, e5, e6) -> - (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i, of_int e5 i, - of_int e6 i) - -let add elem a1 a2 = - let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = - E.add a1 a2 - in - traverse2 f elem a1 a2 - -let sub elem a1 a2 = - let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = - E.sub a1 a2 - in - traverse2 f elem a1 a2 - -let mul elem a1 a2 = - let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = - E.mul a1 a2 - in - traverse2 f elem a1 a2 - -let neg elem a = - let f (type a) (module E : Element_intf with type t = a) (a : a) = - E.neg a - in - traverse1 f elem a - -let max_val elem = - let f (type a) (module E : Element_intf with type t = a) = - E.max_val - in - traverse0 f elem - -let min_val elem = - let rec go : type a . a elem -> a = - fun (elem : a elem) -> - match elem with - | Number {ops} -> - let module E = (val ops) in - E.min_val - | Option elem -> None - | Tup2 (e1, e2) -> (go e1, go e2) - | Tup3 (e1, e2, e3) -> (go e1, go e2, go e3) - | Tup4 (e1, e2, e3, e4) -> (go e1, go e2, go e3, go e4) - | Tup5 (e1, e2, e3, e4, e5) -> (go e1, go e2, go e3, go e4, go e5) - | Tup6 (e1, e2, e3, e4, e5, e6) -> - (go e1, go e2, go e3, go e4, go e5, go e6) - in - go elem - -let rand elem a = - let f (type a) (module E : Element_intf with type t = a) (a : a) = - E.rand a - in - traverse1 f elem a - -let rec compare : type a . a elem -> a -> a -> int = - fun elem a1 a2 -> - match elem with - | Number {ops} -> - let module E = (val ops) in - E.compare a1 a2 - | Option elem -> Option.compare (compare elem) a1 a2 - | Tup2 (e1, e2) -> - let a11, a12 = a1 in - let a21, a22 = a2 in - let x = compare e1 a11 a21 in - if x <> 0 then x - else compare e2 a12 a22 - | Tup3 (e1, e2, e3) -> - let a11, a12, a13 = a1 in - let a21, a22, a23 = a2 in - let x = compare e1 a11 a21 in - if x <> 0 then x - else - let x = compare e2 a12 a22 in - if x <> 0 then x else compare e3 a13 a23 - | Tup4 (e1, e2, e3, e4) -> - let a11, a12, a13, a14 = a1 in - let a21, a22, a23, a24 = a2 in - let x = compare e1 a11 a21 in - if x <> 0 then x - else - let x = compare e2 a12 a22 in - if x <> 0 then x else - let x = compare e3 a13 a23 in - if x <> 0 then x else compare e4 a14 a24 - | Tup5 (e1, e2, e3, e4, e5) -> - let a11, a12, a13, a14, a15 = a1 in - let a21, a22, a23, a24, a25 = a2 in - let x = compare e1 a11 a21 in - if x <> 0 then x - else - let x = compare e2 a12 a22 in - if x <> 0 then x else - let x = compare e3 a13 a23 in - if x <> 0 then x else - let x = compare e4 a14 a24 in - if x <> 0 then x else compare e5 a15 a25 - | Tup6 (e1, e2, e3, e4, e5, e6) -> - let a11, a12, a13, a14, a15, a16 = a1 in - let a21, a22, a23, a24, a25, a26 = a2 in - let x = compare e1 a11 a21 in - if x <> 0 then x - else - let x = compare e2 a12 a22 in - if x <> 0 then x else - let x = compare e3 a13 a23 in - if x <> 0 then x else - let x = compare e4 a14 a24 in - if x <> 0 then x else - let x = compare e5 a15 a25 in - if x <> 0 then x else - compare e6 a16 a26 - -let rec print : type a . a elem -> a -> unit = - let open struct - type packed = P : 'a elem * 'a -> packed - - let print_comma_sep l = - Printf.printf "("; - let rec go l = - match l with - | [] -> assert false - | [P (e,a)] -> - print e a; - Printf.printf ")" - | (P (e,a)) :: l -> - print e a; - Printf.printf ", "; - go l - in - go l - end - in - fun elem a -> - match elem with - | Number {ops} -> - let module E = (val ops) in - E.print a - | Option elem -> - begin match a with - | None -> Printf.printf "None" - | Some a -> begin - Printf.printf "Some "; - print elem a - end - end - | Tup2 (e1, e2) -> - let a1, a2 = a in - print_comma_sep [P (e1, a1); P (e2, a2)] - | Tup3 (e1, e2, e3) -> - let a1, a2, a3 = a in - print_comma_sep [P (e1, a1); P (e2, a2); P (e3, a3)] - | Tup4 (e1, e2, e3, e4) -> - let a1, a2, a3, a4 = a in - print_comma_sep [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4)] - | Tup5 (e1, e2, e3, e4, e5) -> - let a1, a2, a3, a4, a5 = a in - print_comma_sep - [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4); P (e5, a5)] - | Tup6 (e1, e2, e3, e4, e5, e6) -> - let a1, a2, a3, a4, a5, a6 = a in - print_comma_sep - [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4); P (e5, a5); - P (e6, a6)] - -let make_element_ops (type a) (elem : a elem) - : (module Element_intf with type t = a) = - (module struct - type t = a - - let of_int i = of_int elem i - let add t1 t2 = add elem t1 t2 - let sub t1 t2 = sub elem t1 t2 - let mul t1 t2 = mul elem t1 t2 - let neg t = neg elem t - let max_val = max_val elem - let min_val = min_val elem - let rand t = rand elem t - let compare t1 t2 = compare elem t1 t2 - let print t = print elem t - end) diff --git a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli deleted file mode 100644 index 2ba44fb0ad1..00000000000 --- a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* This module defines some helpers for writing tests on arays of unboxed - products. See [README.md] in this directory. *) - -module type Element_intf = Test_gen_u_array.Element_intf - -type 'a elem = - | Number : { ops : (module Element_intf with type t = 'a) } -> 'a elem - | Option : 'a elem -> ('a option) elem - | Tup2 : 'a1 elem * 'a2 elem -> ('a1 * 'a2) elem - | Tup3 : 'a1 elem * 'a2 elem * 'a3 elem -> ('a1 * 'a2 * 'a3) elem - | Tup4 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem - -> ('a1 * 'a2 * 'a3 * 'a4) elem - | Tup5 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem - -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) elem - | Tup6 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem * 'a6 elem - -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) elem - -val int_elem : int elem -val int32_elem : int32 elem -val int64_elem : int64 elem -val nativeint_elem : nativeint elem - -val float_elem : float elem -val float32_elem : float32 elem - -val make_element_ops : 'a elem -> (module Element_intf with type t = 'a) diff --git a/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml b/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml deleted file mode 100644 index 2fb1aaa1827..00000000000 --- a/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml +++ /dev/null @@ -1,682 +0,0 @@ -(* This file is used in [run_makearray_dynamic_tests.ml]. *) -open Stdlib_upstream_compatible -open Stdlib_stable -module List = ListLabels -module String = StringLabels - -let failwithf fmt = Printf.ksprintf failwith fmt -let sprintf = Printf.sprintf - -(* See [test_makearray_dynamic] for the main testing steps! *) - -module Ty : sig - (* A type in the generated code *) - type t = { - ty_code : string; - (* Code for this type expression (e.g. "int option * float") *) - value_code : int -> string; - (* Given some integer seed, generate code for a value of this type. - E.g. passing 3 gives "(Some 3, 3.)" for [int option * float]. *) - mk_value_code : string; - (* Code that dynamically implements [value_code], creating a value from an - integer seed bound to "i". - We should be able to generate this code: - "let mk_value (i : int) : $ty_code = $mk_value_code" *) - eq : string; - (* A function that implements equality in the generated code. - We should be able generate this code: - "let eq : $ty_code @ local -> $ty_code @ local -> bool = $eq" *) - is_gc_ignorable : bool; - (* Whether type only contains non-values/immediates (this used to gate - blit tests, but now that blits work for all types, this field is - unused). *) - } - - (* Generate typedecls for user-defined nominal types that have been created *) - val decls_code : unit -> string list - - (* Takes the record name and (label_name, label_type) pairs *) - val unboxed_record : string -> (string * t) list -> t - - (* [enum 3] represents [type enum3 = A3_0 | A3_1 | A3_2]. *) - val enum : int -> t - - (* Structural and built-in types *) - - val option : t -> t - val tuple : t list -> t - val unboxed_tuple : t list -> t - - val int : t - val float : t - val float_u : t - val float32 : t - val float32_u : t - val int32 : t - val int32_u : t - val int64 : t - val int64_u : t - val nativeint : t - val nativeint_u : t -end = struct - type t = { - ty_code : string; - value_code : int -> string; - mk_value_code : string; - eq : string; - is_gc_ignorable : bool; - } - - let ty_code t = t.ty_code - let value_code t = t.value_code - let mk_value_code t = t.mk_value_code - let is_gc_ignorable t = t.is_gc_ignorable - - let map_value_code ts i = List.map ts ~f:(fun t -> t.value_code i) - - (* If (name, decl) is in this list, we'll generate "type $name = $decl" *) - let decls : (string * string) list ref = ref [] - - let decls_code () = - (* [!decls] is only reversed for aesthetic reasons. *) - List.mapi (List.rev !decls) ~f:(fun i (name, def) -> - (if i == 0 then "type " else "and ") ^ name ^ " = " ^ def - ) - - let add_decl ~name ~def = - match List.assoc_opt name !decls with - | Some def' -> - if not (String.equal def def') then - failwithf - "%s has conflicting definitions:\n %s\nand\n %s" name def' def - | None -> decls := (name, def) :: !decls - - let unboxed_record name labeled_ts = - let lbls, ts = List.split labeled_ts in - let assemble colon_or_eq fields = - let labeled_fields = - List.map2 lbls fields ~f:(fun s x -> s ^ " " ^ colon_or_eq ^ " " ^ x) - in - "#{ " ^ String.concat ~sep:"; " labeled_fields ^ " }" - in - let assemble_expr fields = "(" ^ assemble "=" fields ^ " : " ^ name ^ ")" in - let value_code i = assemble_expr (map_value_code ts i) in - let mk_value_code = assemble_expr (List.map ts ~f:mk_value_code) in - let pat i = - assemble_expr (List.map lbls ~f:(fun s -> s ^ Int.to_string i)) - in - let eq = - let body = - List.map labeled_ts ~f:(fun (s, t) -> sprintf "%s %s1 %s2" t.eq s s) - |> String.concat ~sep:" && " - in - sprintf "(fun %s %s -> %s)" (pat 1) (pat 2) body - in - add_decl ~name ~def:(assemble ":" (List.map ts ~f:ty_code)); - { - ty_code = name; - value_code; - mk_value_code; - eq; - is_gc_ignorable = List.for_all ~f:is_gc_ignorable ts; - } - - let enum size = - let ith_ctor i = sprintf "A%d_%d" size i in - let def = List.init ~len:size ~f:ith_ctor |> String.concat ~sep:" | " in - let eq = - let eq_pat = - List.init ~len:size ~f:(fun i -> ith_ctor i ^ ", " ^ ith_ctor i) - |> String.concat ~sep:" | " - in - sprintf "(fun a b -> match a, b with %s -> true | _ -> false)" eq_pat - in - let mk_value_code = - let brs = - List.init ~len:size ~f:(fun i -> sprintf "%d -> %s" i (ith_ctor i)) - @ ["_ -> assert false"] - in - sprintf "(match Int.rem i %d with %s)" size (String.concat ~sep:" | " brs) - in - let name = sprintf "enum%d" size in - add_decl ~name ~def; - { - ty_code = name; - value_code = (fun i -> ith_ctor (Int.rem i size)); - mk_value_code; - eq; - is_gc_ignorable = true; - } - - let option t = { - ty_code = t.ty_code ^ " option"; - value_code = - (fun i -> if i == 0 then "None" else "Some " ^ t.value_code i); - mk_value_code = - "(if i == 0 then None else Some (" ^ t.mk_value_code ^ "))"; - eq = "(fun a b -> match a, b with None,None -> true | Some a,Some b -> " - ^ t.eq ^ " a b|_->false)"; - is_gc_ignorable = false; - } - - let gen_tuple ~unboxed ts = - let hash = if unboxed then "#" else "" in - let assemble ~sep xs = sprintf "%s(%s)" hash (String.concat ~sep xs) in - let value_code i = assemble ~sep:", " (map_value_code ts i) in - let mk_value_code = assemble ~sep:", " (List.map ts ~f:mk_value_code) in - let eq = - let pat s = - assemble ~sep:", " (List.mapi ts ~f:(fun i _ -> s ^ Int.to_string i)) - in - let body = - List.mapi ts ~f:(fun i t -> sprintf "%s a%d b%d" t.eq i i) - |> String.concat ~sep:" && " - in - sprintf "(fun %s %s -> %s)" (pat "a") (pat "b") body - in - { - ty_code = assemble ~sep:" * " (List.map ts ~f:ty_code); - value_code; - mk_value_code; - eq; - is_gc_ignorable = unboxed && List.for_all ~f:is_gc_ignorable ts; - } - - let tuple = gen_tuple ~unboxed:false - - let unboxed_tuple = gen_tuple ~unboxed:true - - let int = { - ty_code = "int"; - value_code = Int.to_string; - mk_value_code = "i"; - eq = "(fun a b -> Int.equal a b)"; - is_gc_ignorable = true; - } - - let float = { - ty_code = "float"; - value_code = (fun i -> Int.to_string i ^ "."); - mk_value_code = "Float.of_int i"; - eq = "(fun a b -> Float.equal (globalize a) (globalize b))"; - is_gc_ignorable = false; - } - - let float_u = { - ty_code = "float#"; - value_code = (fun i -> "#" ^ Int.to_string i ^ "."); - mk_value_code = "Float_u.of_int i"; - eq = "(fun a b -> Float_u.(equal (add #0. a) (add #0. b)))"; - is_gc_ignorable = true; - } - - let float32 = { - ty_code = "float32"; - value_code = (fun i -> Int.to_string i ^ ".s"); - mk_value_code = "Float32.of_int i"; - eq = "(fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b))"; - is_gc_ignorable = false; - } - - let float32_u = { - ty_code = "float32#"; - value_code = (fun i -> "#" ^ Int.to_string i ^ ".s"); - mk_value_code = "Float32_u.of_int i"; - eq = "(fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b)))"; - is_gc_ignorable = true; - } - - let int32 = { - ty_code = "int32"; - value_code = (fun i -> Int.to_string i ^ "l"); - mk_value_code = "Int32.of_int i"; - eq = "(fun a b -> Int32.equal (globalize a) (globalize b))"; - is_gc_ignorable = false; - } - - let int32_u = { - ty_code = "int32#"; - value_code = (fun i -> "#" ^ Int.to_string i ^ "l"); - mk_value_code = "Int32_u.of_int i"; - eq = "(fun a b -> Int32_u.(equal (add #0l a) (add #0l b)))"; - is_gc_ignorable = true; - } - - let int64 = { - ty_code = "int64"; - value_code = (fun i -> Int.to_string i ^ "L"); - mk_value_code = "Int64.of_int i"; - eq = "(fun a b -> Int64.equal (globalize a) (globalize b))"; - is_gc_ignorable = false; - } - - let int64_u = { - ty_code = "int64#"; - value_code = (fun i -> "#" ^ Int.to_string i ^ "L"); - mk_value_code = "Int64_u.of_int i"; - eq = "(fun a b -> Int64_u.(equal (add #0L a) (add #0L b)))"; - is_gc_ignorable = true; - } - - let nativeint = { - ty_code = "nativeint"; - value_code = (fun i -> (Int.to_string i) ^ "n"); - mk_value_code = "Nativeint.of_int i"; - eq = "(fun a b -> Nativeint.equal (globalize a) (globalize b))"; - is_gc_ignorable = false; - } - - let nativeint_u = { - ty_code = "nativeint#"; - value_code = (fun i -> "#" ^ Int.to_string i ^ "n"); - mk_value_code = "Nativeint_u.of_int i"; - eq = "(fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b)))"; - is_gc_ignorable = true; - } -end - -let ty_ur1 = Ty.(unboxed_record "ur1" ["a", int64_u; "b", float_u]) -let ty_ur2 = Ty.(unboxed_record "ur2" ["a", int64_u; "b", int]) -let ty_ur3 = Ty.(unboxed_record "ur3" ["a", int64_u]) -let ty_ur4 = Ty.(unboxed_record "ur4" ["a", ty_ur1; "b", ty_ur3]) - -(* Types the GC always ignores, which can be used with %makearray_dynamic_uninit *) -let always_ignored_types = Ty.([ - float32_u; float_u; int32_u; int64_u; nativeint_u; ty_ur1; ty_ur3; ty_ur4; - unboxed_tuple [float_u; int32_u; int64_u]; - unboxed_tuple [ - float_u; - unboxed_tuple [int64_u; int64_u]; - float32_u; - unboxed_tuple [int32_u; unboxed_tuple [float32_u; float_u]]; - int64_u; - ]; - unboxed_tuple [int64_u; ty_ur1]; -]) - -let types = always_ignored_types @ Ty.([ - float32; float; int32; int64; nativeint; int; enum 3; ty_ur2; - unboxed_tuple [int; int64]; - unboxed_tuple [ - option int64; - unboxed_tuple [int; int32; float]; - float; - unboxed_tuple [float32; option (tuple [nativeint; nativeint])]; - int32 - ]; - unboxed_tuple [float; float; float]; - unboxed_tuple [ - float; - unboxed_tuple [float; float]; - unboxed_tuple [float; unboxed_tuple [float; float; float]] - ]; - unboxed_tuple [float_u; int; int64_u]; - unboxed_tuple [ - float_u; - unboxed_tuple [int; int64_u]; - float32_u; - unboxed_tuple [int32_u; unboxed_tuple [float32_u; float_u]]; - int; - ]; - unboxed_tuple [ty_ur2; ty_ur1]; -]) - -let preamble = {| -open Stdlib_upstream_compatible -open Stdlib_stable -module List = ListLabels -module String = StringLabels - -external[@layout_poly] makearray_dynamic_uninit_local : - ('a : any_non_null) . int -> 'a array @ local = - "%makearray_dynamic_uninit" - -external[@layout_poly] makearray_dynamic_uninit : - ('a : any_non_null) . int -> 'a array = - "%makearray_dynamic_uninit" - -external[@layout_poly] makearray_dynamic_local : - ('a : any_non_null) . int -> 'a -> 'a array @ local = - "%makearray_dynamic" - -external[@layout_poly] makearray_dynamic : - ('a : any_non_null) . int -> 'a -> 'a array = - "%makearray_dynamic" - -external[@layout_poly] get : - ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = - "%array_safe_get" - -external[@layout_poly] set : - ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = - "%array_safe_set" - -external[@layout_poly] unsafe_blit : - ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> ('a array[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = - "%arrayblit" - -let failwithf fmt = Printf.ksprintf failwith fmt - -external globalize : local_ 'a -> 'a = "%obj_dup";; - -(* Redefine iter to infer locality *) -let rec iter ~f = function - [] -> () - | a::l -> f a; iter ~f l - -let tests_run = ref [] - -let mark_test_run test_id = - if not (List.mem ~set:!tests_run test_id) then - tests_run := test_id :: !tests_run - -(* Various interesting values *) - -let sizes = [ 0; 1; 2; 30; 31; 32 ] - -let bad_indices size = - [ -100; -2; -1; size; size + 1; size + 100; Int.min_int; Int.max_int ] - -let blit_offsets size = - let candidates = [ 0; 1; size / 3; size / 2; size - 1; size ] in - List.filter candidates ~f:(fun ofs -> ofs > 0 && ofs < size) - |> List.sort_uniq ~cmp:Int.compare - -let blit_lens ~ofs1 ~ofs2 ~size1 ~size2 = - let len_until_end = Int.min (size1 - ofs1) (size2 - ofs2) in - let candidates = [ 0; 1; size1 / 2; len_until_end - 1; len_until_end ] in - List.filter candidates ~f:(fun len -> ofs1 + len <= size1 && ofs2 + len <= size2) - |> List.sort_uniq ~cmp:Int.compare -|} - -let indent = ref 0 - -let with_indent f = incr indent; f (); decr indent - -let line fmt = - Printf.ksprintf - (fun s -> - let indent = Seq.init (!indent * 2) (fun _ -> ' ') |> String.of_seq in - print_endline (indent ^ s); - flush stdout) - fmt - -let print_in_test s = - line {|let () = Printf.printf "%s%%!\n";;|} (String.escaped s) - -let seq_print_in_test s = - line {|print_endline "%s%!";|} (String.escaped s) - -let makearray_dynamic_fn ~uninit ~local = - let uninit_s = if uninit then "_uninit" else "" in - let local_s = if local then "_local" else "" in - "makearray_dynamic" ^ uninit_s ^ local_s - -type debug_expr = { expr : string ; format_s : string } - -let concat_with_leading_spaces l = - List.map l ~f:(fun s -> " " ^ s) - |> String.concat ~sep:"" - -let combine_debug_exprs (l : debug_expr list) : debug_expr = - let debug_expr_to_tuple { expr ; format_s } = expr, format_s in - let exprs, format_ss = List.split (List.rev_map ~f:debug_expr_to_tuple l) in - let expr = concat_with_leading_spaces exprs in - let format_s = concat_with_leading_spaces format_ss in - { expr; format_s } - -let seq_print_debug_exprs ~debug_exprs = - let { expr ; format_s } = combine_debug_exprs debug_exprs in - line {|Printf.printf "%s: %s\n%%!"%s;|} expr format_s expr - -let test_id = ref 0 - -let seq_assert ~debug_exprs s = - incr test_id; - let { expr ; format_s } = combine_debug_exprs debug_exprs in - line "mark_test_run %d;" !test_id; - line "let test = %s in" s; - line {|if not test then failwithf "test %d failed%s"%s;|} - !test_id format_s expr - -let for_ var ~from ~to_ ~debug_exprs f = - line "for %s = %s to %s do" var from to_; - with_indent (fun () -> - let debug_exprs = { expr = var; format_s = "%d" } :: debug_exprs in - f ~debug_exprs - ); - line "done;" - -let for_i_below_size = for_ "i" ~from:"0" ~to_:"size - 1" - -(* Iterate through a list of ints *) -let iter l var ~debug_exprs f = - line "iter (%s) ~f:(fun %s ->" l var; - with_indent (fun () -> - let debug_exprs = { expr = var; format_s = "%d" } :: debug_exprs in - f ~debug_exprs - ); - line ") [@nontail];" - -let section s = - let s_as_stars = String.init (String.length s) ~f:(fun _ -> '*') in - line "(**%s**)" s_as_stars; - line "(* %s *)" s; - line "(**%s**)" s_as_stars - -(* Test steps: - 1. Create an array, possibly local, possibly uninitialized - 2. For initialized arrays, check all elements have the correct value - 3. Fill array with distinct values and read back those values - 4. Check that getting bad indices errors - 5. Check that setting bad indices errors - 6. Check that array contents were unaffected by setting bad indices - 7. Overlapping blits - 8. Blits to heap arrays - 9. Blits to local arrays -*) -let test_makearray_dynamic ~uninit ~local ty = - let makearray_dynamic = makearray_dynamic_fn ~uninit ~local in - let debug_exprs = [{ expr = "size"; format_s = "%d"}] in - let ty_array_s = ty.Ty.ty_code ^ " array" in - (* seq_print_in_test ty.Ty.ty_code; *) - section (" " ^ ty.Ty.ty_code ^ " "); - line "let eq = %s in" ty.Ty.eq; - line "let mk_value i = %s in" ty.Ty.mk_value_code; - line "(* 1. Create an array of size [size] *)"; - (if uninit then ( - line "let a : %s = %s size in" ty_array_s makearray_dynamic; - line "(* 2. For uninitialized arrays, element values are unspecified *)" - ) else - line "let a : %s = %s size %s in" ty_array_s makearray_dynamic (ty.Ty.value_code 0); - line "(* 2. For initialized arrays, check all elements have the correct value *)"; - for_i_below_size ~debug_exprs (fun ~debug_exprs -> - line "let el = get a i in"; - if uninit then - line "let _ = el in ()" - else ( - let test = sprintf "eq el %s" (ty.Ty.value_code 0) in - seq_assert ~debug_exprs test; - ) - )); - line "(* 3. Fill [a] with distinct values and read back those values *)"; - for_i_below_size ~debug_exprs (fun ~debug_exprs -> - line "set a i (mk_value i);" - ); - line "Gc.compact ();"; - for_i_below_size ~debug_exprs (fun ~debug_exprs -> - seq_assert ~debug_exprs "eq (get a i) (mk_value i)" - ); - iter "bad_indices size" "i" ~debug_exprs (fun ~debug_exprs -> - line "(* 4. Getting bad indices errors *)"; - line "let raises ="; - with_indent (fun () -> - line "match get a i with"; - line "| exception Invalid_argument _ -> true"; - line "| _ -> false" - ); - line "in"; - seq_assert ~debug_exprs "raises"; - line "(* 5. Setting bad indices errors *)"; - line "let raises ="; - with_indent (fun () -> - line "match set a i %s with" (ty.Ty.value_code 0); - line "| exception Invalid_argument _ -> true"; - line "| _ -> false" - ); - line "in"; - seq_assert ~debug_exprs "raises" - ); - line "Gc.compact ();"; - line "(* 6. Array contents were unaffacted by setting bad indices *)"; - for_i_below_size ~debug_exprs (fun ~debug_exprs -> - seq_assert ~debug_exprs "eq (get a i) (mk_value i)" - ); - (* Blits currently only work for GC ignorable values *) - line "(* 7. Overlapping blits *)"; - iter "blit_offsets size" "ofs1" ~debug_exprs (fun ~debug_exprs -> - iter "blit_offsets size" "ofs2" ~debug_exprs (fun ~debug_exprs -> - let lens = "blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size" in - iter lens "len" ~debug_exprs (fun ~debug_exprs -> - line "unsafe_blit a ofs1 a ofs2 len;"; - for_i_below_size ~debug_exprs (fun ~debug_exprs -> - line "let expected_src_i ="; - with_indent (fun () -> - line "if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i" - ); - line "in"; - seq_assert ~debug_exprs "eq (get a i) (mk_value expected_src_i)" - ); - line "(* Reset array *)"; - for_i_below_size ~debug_exprs (fun ~debug_exprs -> - line "set a i (mk_value i);" - ) - ); - ); - ); - line "Gc.compact ();"; - let test_blit_to ~to_local = - iter "sizes" "size2" ~debug_exprs (fun ~debug_exprs -> - iter "blit_offsets size" "ofs1" ~debug_exprs (fun ~debug_exprs -> - iter "blit_offsets size2" "ofs2" ~debug_exprs (fun ~debug_exprs -> - let lens = "blit_lens ~ofs1 ~ofs2 ~size1:size ~size2" in - iter lens "len" ~debug_exprs (fun ~debug_exprs -> - (if to_local then - line "let local_ a2 = makearray_dynamic_local size2 %s in" (ty.Ty.value_code 0) - else - line "let a2 = makearray_dynamic size2 %s in" (ty.Ty.value_code 0)); - line "unsafe_blit a ofs1 a2 ofs2 len;"; - for_ "i" ~from:"0" ~to_:"size2 - 1" ~debug_exprs (fun ~debug_exprs -> - line "let expected_src_i ="; - with_indent (fun () -> - line "if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0" - ); - line "in"; - seq_assert ~debug_exprs "eq (get a2 i) (mk_value expected_src_i)" - ) - ) - ) - ) - ); - line "Gc.compact ();" - in - line "(* 8. Blits to heap arrays *)"; - test_blit_to ~to_local:false; - line "(* 9. Blits to local arrays *)"; - test_blit_to ~to_local:true; - print_endline "" - -let toplevel_unit_block f = - assert (Int.equal !indent 0); - line "let () ="; - with_indent (fun () -> - f (); line "()" - ); - line ";;"; - line "" - -let main ~bytecode = - let debug_exprs = [] in - line {|(* TEST - include stdlib_stable; - include stdlib_upstream_compatible;|}; - if bytecode then ( - line {| flags = "-extension layouts_beta";|}; - (* CR layouts: enable for arm64 once float32 is available *) - line {| arch_amd64;|}; - line {| bytecode;|}; - ) else ( - line {| modules = "stubs.c";|}; - line {| flags = "-extension layouts_beta -extension simd_beta";|}; - line {| flambda2;|}; - line {| stack-allocation;|}; - line {| arch_amd64;|}; - line {| native;|}; - ); - line {|*)|}; - line "(** This is code generated by [generate_makearray_dynamic_tests.ml]. *)"; - line ""; - line "%s" preamble; - List.iter (Ty.decls_code ()) ~f:(fun s -> line "%s" s); - line ""; - line "(* Catch metaprogramming errors early *)"; - toplevel_unit_block (fun () -> - let open Ty in - line "(* Check types and constants *)"; - List.iter types ~f:(fun ty -> - line "let _ : %s = %s in" ty.ty_code (ty.value_code 0) - ); - line "(* Check equality and mk_value functions *)"; - List.iter types ~f:(fun ty -> - line "let eq : %s @ local -> %s @ local -> bool = %s in" - ty.ty_code ty.ty_code ty.eq; - line "let mk_value i = %s in" ty.mk_value_code; - seq_assert ~debug_exprs - (sprintf "eq (mk_value 1) %s" (ty.value_code 1)); - seq_assert ~debug_exprs - (sprintf "eq %s %s" (ty.value_code 1) (ty.value_code 1)); - seq_assert ~debug_exprs - (sprintf "not (eq %s %s)" (ty.value_code 1) (ty.value_code 2)) - ); - line "(* Check always-GC-ignored types *)"; - List.iter always_ignored_types ~f:(fun ty -> - line "let _ = (makearray_dynamic_uninit 1 : %s array) in" (ty.ty_code) - ); - ); - List.iter [false; true] ~f:(fun uninit -> - List.iter [false; true] ~f:(fun local -> - line "let test_%s size =" (makearray_dynamic_fn ~uninit ~local); - with_indent (fun () -> - let tys = if uninit then always_ignored_types else types in - List.iter tys ~f:(test_makearray_dynamic ~uninit ~local); - line "()"; - ); - line ""; - ) - ); - line "(* Main tests *)"; - toplevel_unit_block (fun () -> - List.iter [false; true] ~f:(fun uninit -> - List.iter [false; true] ~f:(fun local -> - let test_fn = "test_" ^ makearray_dynamic_fn ~uninit ~local in - seq_print_in_test test_fn; - line "iter sizes ~f:%s;" test_fn - ) - ) - ); - line "for i = 1 to %d do" !test_id; - with_indent (fun () -> - line - {|if not (List.mem ~set:!tests_run i) then failwithf "test %%d not run" i|} - ); - line "done;;"; - print_in_test "All tests passed." - -let () = - let bytecode = - match Sys.argv with - | [| _; "native" |] -> false - | [| _; "byte" |] -> true - | _ -> failwith (sprintf "Usage %s " Sys.argv.(0)) - in - main ~bytecode diff --git a/testsuite/tests/typing-layouts-arrays/generated_test.ml b/testsuite/tests/typing-layouts-arrays/generated_test.ml deleted file mode 100644 index 873b18854ae..00000000000 --- a/testsuite/tests/typing-layouts-arrays/generated_test.ml +++ /dev/null @@ -1,8785 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - modules = "stubs.c"; - flags = "-extension layouts_beta -extension simd_beta"; - flambda2; - stack-allocation; - arch_amd64; - native; -*) -(** This is code generated by [generate_makearray_dynamic_tests.ml]. *) - - -open Stdlib_upstream_compatible -open Stdlib_stable -module List = ListLabels -module String = StringLabels - -external[@layout_poly] makearray_dynamic_uninit_local : - ('a : any_non_null) . int -> 'a array @ local = - "%makearray_dynamic_uninit" - -external[@layout_poly] makearray_dynamic_uninit : - ('a : any_non_null) . int -> 'a array = - "%makearray_dynamic_uninit" - -external[@layout_poly] makearray_dynamic_local : - ('a : any_non_null) . int -> 'a -> 'a array @ local = - "%makearray_dynamic" - -external[@layout_poly] makearray_dynamic : - ('a : any_non_null) . int -> 'a -> 'a array = - "%makearray_dynamic" - -external[@layout_poly] get : - ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = - "%array_safe_get" - -external[@layout_poly] set : - ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = - "%array_safe_set" - -external[@layout_poly] unsafe_blit : - ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> ('a array[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = - "%arrayblit" - -let failwithf fmt = Printf.ksprintf failwith fmt - -external globalize : local_ 'a -> 'a = "%obj_dup";; - -(* Redefine iter to infer locality *) -let rec iter ~f = function - [] -> () - | a::l -> f a; iter ~f l - -let tests_run = ref [] - -let mark_test_run test_id = - if not (List.mem ~set:!tests_run test_id) then - tests_run := test_id :: !tests_run - -(* Various interesting values *) - -let sizes = [ 0; 1; 2; 30; 31; 32 ] - -let bad_indices size = - [ -100; -2; -1; size; size + 1; size + 100; Int.min_int; Int.max_int ] - -let blit_offsets size = - let candidates = [ 0; 1; size / 3; size / 2; size - 1; size ] in - List.filter candidates ~f:(fun ofs -> ofs > 0 && ofs < size) - |> List.sort_uniq ~cmp:Int.compare - -let blit_lens ~ofs1 ~ofs2 ~size1 ~size2 = - let len_until_end = Int.min (size1 - ofs1) (size2 - ofs2) in - let candidates = [ 0; 1; size1 / 2; len_until_end - 1; len_until_end ] in - List.filter candidates ~f:(fun len -> ofs1 + len <= size1 && ofs2 + len <= size2) - |> List.sort_uniq ~cmp:Int.compare - -type ur1 = #{ a : int64#; b : float# } -and ur2 = #{ a : int64#; b : int } -and ur3 = #{ a : int64# } -and ur4 = #{ a : ur1; b : ur3 } -and enum3 = A3_0 | A3_1 | A3_2 - -(* Catch metaprogramming errors early *) -let () = - (* Check types and constants *) - let _ : float32# = #0.s in - let _ : float# = #0. in - let _ : int32# = #0l in - let _ : int64# = #0L in - let _ : nativeint# = #0n in - let _ : ur1 = (#{ a = #0L; b = #0. } : ur1) in - let _ : ur3 = (#{ a = #0L } : ur3) in - let _ : ur4 = (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - let _ : #(float# * int32# * int64#) = #(#0., #0l, #0L) in - let _ : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) = #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - let _ : #(int64# * ur1) = #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - let _ : float32 = 0.s in - let _ : float = 0. in - let _ : int32 = 0l in - let _ : int64 = 0L in - let _ : nativeint = 0n in - let _ : int = 0 in - let _ : enum3 = A3_0 in - let _ : ur2 = (#{ a = #0L; b = 0 } : ur2) in - let _ : #(int * int64) = #(0, 0L) in - let _ : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) = #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - let _ : #(float * float * float) = #(0., 0., 0.) in - let _ : #(float * #(float * float) * #(float * #(float * float * float))) = #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - let _ : #(float# * int * int64#) = #(#0., 0, #0L) in - let _ : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) = #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - let _ : #(ur2 * ur1) = #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - (* Check equality and mk_value functions *) - let eq : float32# @ local -> float32# @ local -> bool = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in - let mk_value i = Float32_u.of_int i in - mark_test_run 1; - let test = eq (mk_value 1) #1.s in - if not test then failwithf "test 1 failed"; - mark_test_run 2; - let test = eq #1.s #1.s in - if not test then failwithf "test 2 failed"; - mark_test_run 3; - let test = not (eq #1.s #2.s) in - if not test then failwithf "test 3 failed"; - let eq : float# @ local -> float# @ local -> bool = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in - let mk_value i = Float_u.of_int i in - mark_test_run 4; - let test = eq (mk_value 1) #1. in - if not test then failwithf "test 4 failed"; - mark_test_run 5; - let test = eq #1. #1. in - if not test then failwithf "test 5 failed"; - mark_test_run 6; - let test = not (eq #1. #2.) in - if not test then failwithf "test 6 failed"; - let eq : int32# @ local -> int32# @ local -> bool = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in - let mk_value i = Int32_u.of_int i in - mark_test_run 7; - let test = eq (mk_value 1) #1l in - if not test then failwithf "test 7 failed"; - mark_test_run 8; - let test = eq #1l #1l in - if not test then failwithf "test 8 failed"; - mark_test_run 9; - let test = not (eq #1l #2l) in - if not test then failwithf "test 9 failed"; - let eq : int64# @ local -> int64# @ local -> bool = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in - let mk_value i = Int64_u.of_int i in - mark_test_run 10; - let test = eq (mk_value 1) #1L in - if not test then failwithf "test 10 failed"; - mark_test_run 11; - let test = eq #1L #1L in - if not test then failwithf "test 11 failed"; - mark_test_run 12; - let test = not (eq #1L #2L) in - if not test then failwithf "test 12 failed"; - let eq : nativeint# @ local -> nativeint# @ local -> bool = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in - let mk_value i = Nativeint_u.of_int i in - mark_test_run 13; - let test = eq (mk_value 1) #1n in - if not test then failwithf "test 13 failed"; - mark_test_run 14; - let test = eq #1n #1n in - if not test then failwithf "test 14 failed"; - mark_test_run 15; - let test = not (eq #1n #2n) in - if not test then failwithf "test 15 failed"; - let eq : ur1 @ local -> ur1 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in - mark_test_run 16; - let test = eq (mk_value 1) (#{ a = #1L; b = #1. } : ur1) in - if not test then failwithf "test 16 failed"; - mark_test_run 17; - let test = eq (#{ a = #1L; b = #1. } : ur1) (#{ a = #1L; b = #1. } : ur1) in - if not test then failwithf "test 17 failed"; - mark_test_run 18; - let test = not (eq (#{ a = #1L; b = #1. } : ur1) (#{ a = #2L; b = #2. } : ur1)) in - if not test then failwithf "test 18 failed"; - let eq : ur3 @ local -> ur3 @ local -> bool = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in - let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in - mark_test_run 19; - let test = eq (mk_value 1) (#{ a = #1L } : ur3) in - if not test then failwithf "test 19 failed"; - mark_test_run 20; - let test = eq (#{ a = #1L } : ur3) (#{ a = #1L } : ur3) in - if not test then failwithf "test 20 failed"; - mark_test_run 21; - let test = not (eq (#{ a = #1L } : ur3) (#{ a = #2L } : ur3)) in - if not test then failwithf "test 21 failed"; - let eq : ur4 @ local -> ur4 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in - let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in - mark_test_run 22; - let test = eq (mk_value 1) (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) in - if not test then failwithf "test 22 failed"; - mark_test_run 23; - let test = eq (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) in - if not test then failwithf "test 23 failed"; - mark_test_run 24; - let test = not (eq (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) (#{ a = (#{ a = #2L; b = #2. } : ur1); b = (#{ a = #2L } : ur3) } : ur4)) in - if not test then failwithf "test 24 failed"; - let eq : #(float# * int32# * int64#) @ local -> #(float# * int32# * int64#) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in - mark_test_run 25; - let test = eq (mk_value 1) #(#1., #1l, #1L) in - if not test then failwithf "test 25 failed"; - mark_test_run 26; - let test = eq #(#1., #1l, #1L) #(#1., #1l, #1L) in - if not test then failwithf "test 26 failed"; - mark_test_run 27; - let test = not (eq #(#1., #1l, #1L) #(#2., #2l, #2L)) in - if not test then failwithf "test 27 failed"; - let eq : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) @ local -> #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in - mark_test_run 28; - let test = eq (mk_value 1) #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) in - if not test then failwithf "test 28 failed"; - mark_test_run 29; - let test = eq #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) in - if not test then failwithf "test 29 failed"; - mark_test_run 30; - let test = not (eq #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) #(#2., #(#2L, #2L), #2.s, #(#2l, #(#2.s, #2.)), #2L)) in - if not test then failwithf "test 30 failed"; - let eq : #(int64# * ur1) @ local -> #(int64# * ur1) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - mark_test_run 31; - let test = eq (mk_value 1) #(#1L, (#{ a = #1L; b = #1. } : ur1)) in - if not test then failwithf "test 31 failed"; - mark_test_run 32; - let test = eq #(#1L, (#{ a = #1L; b = #1. } : ur1)) #(#1L, (#{ a = #1L; b = #1. } : ur1)) in - if not test then failwithf "test 32 failed"; - mark_test_run 33; - let test = not (eq #(#1L, (#{ a = #1L; b = #1. } : ur1)) #(#2L, (#{ a = #2L; b = #2. } : ur1))) in - if not test then failwithf "test 33 failed"; - let eq : float32 @ local -> float32 @ local -> bool = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in - let mk_value i = Float32.of_int i in - mark_test_run 34; - let test = eq (mk_value 1) 1.s in - if not test then failwithf "test 34 failed"; - mark_test_run 35; - let test = eq 1.s 1.s in - if not test then failwithf "test 35 failed"; - mark_test_run 36; - let test = not (eq 1.s 2.s) in - if not test then failwithf "test 36 failed"; - let eq : float @ local -> float @ local -> bool = (fun a b -> Float.equal (globalize a) (globalize b)) in - let mk_value i = Float.of_int i in - mark_test_run 37; - let test = eq (mk_value 1) 1. in - if not test then failwithf "test 37 failed"; - mark_test_run 38; - let test = eq 1. 1. in - if not test then failwithf "test 38 failed"; - mark_test_run 39; - let test = not (eq 1. 2.) in - if not test then failwithf "test 39 failed"; - let eq : int32 @ local -> int32 @ local -> bool = (fun a b -> Int32.equal (globalize a) (globalize b)) in - let mk_value i = Int32.of_int i in - mark_test_run 40; - let test = eq (mk_value 1) 1l in - if not test then failwithf "test 40 failed"; - mark_test_run 41; - let test = eq 1l 1l in - if not test then failwithf "test 41 failed"; - mark_test_run 42; - let test = not (eq 1l 2l) in - if not test then failwithf "test 42 failed"; - let eq : int64 @ local -> int64 @ local -> bool = (fun a b -> Int64.equal (globalize a) (globalize b)) in - let mk_value i = Int64.of_int i in - mark_test_run 43; - let test = eq (mk_value 1) 1L in - if not test then failwithf "test 43 failed"; - mark_test_run 44; - let test = eq 1L 1L in - if not test then failwithf "test 44 failed"; - mark_test_run 45; - let test = not (eq 1L 2L) in - if not test then failwithf "test 45 failed"; - let eq : nativeint @ local -> nativeint @ local -> bool = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in - let mk_value i = Nativeint.of_int i in - mark_test_run 46; - let test = eq (mk_value 1) 1n in - if not test then failwithf "test 46 failed"; - mark_test_run 47; - let test = eq 1n 1n in - if not test then failwithf "test 47 failed"; - mark_test_run 48; - let test = not (eq 1n 2n) in - if not test then failwithf "test 48 failed"; - let eq : int @ local -> int @ local -> bool = (fun a b -> Int.equal a b) in - let mk_value i = i in - mark_test_run 49; - let test = eq (mk_value 1) 1 in - if not test then failwithf "test 49 failed"; - mark_test_run 50; - let test = eq 1 1 in - if not test then failwithf "test 50 failed"; - mark_test_run 51; - let test = not (eq 1 2) in - if not test then failwithf "test 51 failed"; - let eq : enum3 @ local -> enum3 @ local -> bool = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in - let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in - mark_test_run 52; - let test = eq (mk_value 1) A3_1 in - if not test then failwithf "test 52 failed"; - mark_test_run 53; - let test = eq A3_1 A3_1 in - if not test then failwithf "test 53 failed"; - mark_test_run 54; - let test = not (eq A3_1 A3_2) in - if not test then failwithf "test 54 failed"; - let eq : ur2 @ local -> ur2 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in - mark_test_run 55; - let test = eq (mk_value 1) (#{ a = #1L; b = 1 } : ur2) in - if not test then failwithf "test 55 failed"; - mark_test_run 56; - let test = eq (#{ a = #1L; b = 1 } : ur2) (#{ a = #1L; b = 1 } : ur2) in - if not test then failwithf "test 56 failed"; - mark_test_run 57; - let test = not (eq (#{ a = #1L; b = 1 } : ur2) (#{ a = #2L; b = 2 } : ur2)) in - if not test then failwithf "test 57 failed"; - let eq : #(int * int64) @ local -> #(int * int64) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in - let mk_value i = #(i, Int64.of_int i) in - mark_test_run 58; - let test = eq (mk_value 1) #(1, 1L) in - if not test then failwithf "test 58 failed"; - mark_test_run 59; - let test = eq #(1, 1L) #(1, 1L) in - if not test then failwithf "test 59 failed"; - mark_test_run 60; - let test = not (eq #(1, 1L) #(2, 2L)) in - if not test then failwithf "test 60 failed"; - let eq : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) @ local -> #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in - let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in - mark_test_run 61; - let test = eq (mk_value 1) #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) in - if not test then failwithf "test 61 failed"; - mark_test_run 62; - let test = eq #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) in - if not test then failwithf "test 62 failed"; - mark_test_run 63; - let test = not (eq #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) #(Some 2L, #(2, 2l, 2.), 2., #(2.s, Some (2n, 2n)), 2l)) in - if not test then failwithf "test 63 failed"; - let eq : #(float * float * float) @ local -> #(float * float * float) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in - let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in - mark_test_run 64; - let test = eq (mk_value 1) #(1., 1., 1.) in - if not test then failwithf "test 64 failed"; - mark_test_run 65; - let test = eq #(1., 1., 1.) #(1., 1., 1.) in - if not test then failwithf "test 65 failed"; - mark_test_run 66; - let test = not (eq #(1., 1., 1.) #(2., 2., 2.)) in - if not test then failwithf "test 66 failed"; - let eq : #(float * #(float * float) * #(float * #(float * float * float))) @ local -> #(float * #(float * float) * #(float * #(float * float * float))) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in - let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in - mark_test_run 67; - let test = eq (mk_value 1) #(1., #(1., 1.), #(1., #(1., 1., 1.))) in - if not test then failwithf "test 67 failed"; - mark_test_run 68; - let test = eq #(1., #(1., 1.), #(1., #(1., 1., 1.))) #(1., #(1., 1.), #(1., #(1., 1., 1.))) in - if not test then failwithf "test 68 failed"; - mark_test_run 69; - let test = not (eq #(1., #(1., 1.), #(1., #(1., 1., 1.))) #(2., #(2., 2.), #(2., #(2., 2., 2.)))) in - if not test then failwithf "test 69 failed"; - let eq : #(float# * int * int64#) @ local -> #(float# * int * int64#) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in - mark_test_run 70; - let test = eq (mk_value 1) #(#1., 1, #1L) in - if not test then failwithf "test 70 failed"; - mark_test_run 71; - let test = eq #(#1., 1, #1L) #(#1., 1, #1L) in - if not test then failwithf "test 71 failed"; - mark_test_run 72; - let test = not (eq #(#1., 1, #1L) #(#2., 2, #2L)) in - if not test then failwithf "test 72 failed"; - let eq : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) @ local -> #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in - mark_test_run 73; - let test = eq (mk_value 1) #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) in - if not test then failwithf "test 73 failed"; - mark_test_run 74; - let test = eq #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) in - if not test then failwithf "test 74 failed"; - mark_test_run 75; - let test = not (eq #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) #(#2., #(2, #2L), #2.s, #(#2l, #(#2.s, #2.)), 2)) in - if not test then failwithf "test 75 failed"; - let eq : #(ur2 * ur1) @ local -> #(ur2 * ur1) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - mark_test_run 76; - let test = eq (mk_value 1) #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) in - if not test then failwithf "test 76 failed"; - mark_test_run 77; - let test = eq #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) in - if not test then failwithf "test 77 failed"; - mark_test_run 78; - let test = not (eq #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) #((#{ a = #2L; b = 2 } : ur2), (#{ a = #2L; b = #2. } : ur1))) in - if not test then failwithf "test 78 failed"; - (* Check always-GC-ignored types *) - let _ = (makearray_dynamic_uninit 1 : float32# array) in - let _ = (makearray_dynamic_uninit 1 : float# array) in - let _ = (makearray_dynamic_uninit 1 : int32# array) in - let _ = (makearray_dynamic_uninit 1 : int64# array) in - let _ = (makearray_dynamic_uninit 1 : nativeint# array) in - let _ = (makearray_dynamic_uninit 1 : ur1 array) in - let _ = (makearray_dynamic_uninit 1 : ur3 array) in - let _ = (makearray_dynamic_uninit 1 : ur4 array) in - let _ = (makearray_dynamic_uninit 1 : #(float# * int32# * int64#) array) in - let _ = (makearray_dynamic_uninit 1 : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array) in - let _ = (makearray_dynamic_uninit 1 : #(int64# * ur1) array) in - () -;; - -let test_makearray_dynamic size = - (****************) - (* float32# *) - (****************) - let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in - let mk_value i = Float32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float32# array = makearray_dynamic size #0.s in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 79; - let test = eq el #0.s in - if not test then failwithf "test 79 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 80; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 80 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 81; - let test = raises in - if not test then failwithf "test 81 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0.s with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 82; - let test = raises in - if not test then failwithf "test 82 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 83; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 83 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 84; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 84 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 85; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 85 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 86; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 86 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* float# *) - (**************) - let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in - let mk_value i = Float_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float# array = makearray_dynamic size #0. in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 87; - let test = eq el #0. in - if not test then failwithf "test 87 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 88; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 88 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 89; - let test = raises in - if not test then failwithf "test 89 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0. with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 90; - let test = raises in - if not test then failwithf "test 90 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 91; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 91 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 92; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 92 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 93; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 93 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 94; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 94 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int32# *) - (**************) - let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in - let mk_value i = Int32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int32# array = makearray_dynamic size #0l in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 95; - let test = eq el #0l in - if not test then failwithf "test 95 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 96; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 96 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 97; - let test = raises in - if not test then failwithf "test 97 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0l with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 98; - let test = raises in - if not test then failwithf "test 98 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 99; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 99 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 100; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 100 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 101; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 101 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 102; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 102 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int64# *) - (**************) - let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in - let mk_value i = Int64_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int64# array = makearray_dynamic size #0L in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 103; - let test = eq el #0L in - if not test then failwithf "test 103 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 104; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 104 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 105; - let test = raises in - if not test then failwithf "test 105 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0L with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 106; - let test = raises in - if not test then failwithf "test 106 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 107; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 107 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 108; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 108 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 109; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 109 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 110; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 110 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (******************) - (* nativeint# *) - (******************) - let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in - let mk_value i = Nativeint_u.of_int i in - (* 1. Create an array of size [size] *) - let a : nativeint# array = makearray_dynamic size #0n in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 111; - let test = eq el #0n in - if not test then failwithf "test 111 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 112; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 112 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 113; - let test = raises in - if not test then failwithf "test 113 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0n with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 114; - let test = raises in - if not test then failwithf "test 114 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 115; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 115 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 116; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 116 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 117; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 117 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 118; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 118 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur1 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in - (* 1. Create an array of size [size] *) - let a : ur1 array = makearray_dynamic size (#{ a = #0L; b = #0. } : ur1) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 119; - let test = eq el (#{ a = #0L; b = #0. } : ur1) in - if not test then failwithf "test 119 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 120; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 120 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 121; - let test = raises in - if not test then failwithf "test 121 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L; b = #0. } : ur1) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 122; - let test = raises in - if not test then failwithf "test 122 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 123; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 123 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 124; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 124 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 125; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 125 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 126; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 126 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur3 *) - (***********) - let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in - let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in - (* 1. Create an array of size [size] *) - let a : ur3 array = makearray_dynamic size (#{ a = #0L } : ur3) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 127; - let test = eq el (#{ a = #0L } : ur3) in - if not test then failwithf "test 127 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 128; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 128 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 129; - let test = raises in - if not test then failwithf "test 129 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L } : ur3) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 130; - let test = raises in - if not test then failwithf "test 130 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 131; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 131 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 132; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 132 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 133; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 133 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 134; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 134 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur4 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in - let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in - (* 1. Create an array of size [size] *) - let a : ur4 array = makearray_dynamic size (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 135; - let test = eq el (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - if not test then failwithf "test 135 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 136; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 136 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 137; - let test = raises in - if not test then failwithf "test 137 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 138; - let test = raises in - if not test then failwithf "test 138 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 139; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 139 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 140; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 140 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 141; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 141 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 142; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 142 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************************) - (* #(float# * int32# * int64#) *) - (***********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * int32# * int64#) array = makearray_dynamic size #(#0., #0l, #0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 143; - let test = eq el #(#0., #0l, #0L) in - if not test then failwithf "test 143 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 144; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 144 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 145; - let test = raises in - if not test then failwithf "test 145 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #0l, #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 146; - let test = raises in - if not test then failwithf "test 146 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 147; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 147 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 148; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 148 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 149; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 149 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 150; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 150 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*********************************************************************************************) - (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) - (*********************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic size #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 151; - let test = eq el #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - if not test then failwithf "test 151 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 152; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 152 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 153; - let test = raises in - if not test then failwithf "test 153 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 154; - let test = raises in - if not test then failwithf "test 154 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 155; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 155 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 156; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 156 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 157; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 157 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 158; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 158 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************) - (* #(int64# * ur1) *) - (***********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - (* 1. Create an array of size [size] *) - let a : #(int64# * ur1) array = makearray_dynamic size #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 159; - let test = eq el #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - if not test then failwithf "test 159 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 160; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 160 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 161; - let test = raises in - if not test then failwithf "test 161 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 162; - let test = raises in - if not test then failwithf "test 162 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 163; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 163 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 164; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 164 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 165; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 165 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 166; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 166 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***************) - (* float32 *) - (***************) - let eq = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in - let mk_value i = Float32.of_int i in - (* 1. Create an array of size [size] *) - let a : float32 array = makearray_dynamic size 0.s in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 167; - let test = eq el 0.s in - if not test then failwithf "test 167 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 168; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 168 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 169; - let test = raises in - if not test then failwithf "test 169 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0.s with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 170; - let test = raises in - if not test then failwithf "test 170 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 171; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 171 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 172; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 172 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 173; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 173 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 174; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 174 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* float *) - (*************) - let eq = (fun a b -> Float.equal (globalize a) (globalize b)) in - let mk_value i = Float.of_int i in - (* 1. Create an array of size [size] *) - let a : float array = makearray_dynamic size 0. in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 175; - let test = eq el 0. in - if not test then failwithf "test 175 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 176; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 176 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 177; - let test = raises in - if not test then failwithf "test 177 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0. with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 178; - let test = raises in - if not test then failwithf "test 178 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 179; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 179 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 180; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 180 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 181; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 181 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 182; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 182 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* int32 *) - (*************) - let eq = (fun a b -> Int32.equal (globalize a) (globalize b)) in - let mk_value i = Int32.of_int i in - (* 1. Create an array of size [size] *) - let a : int32 array = makearray_dynamic size 0l in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 183; - let test = eq el 0l in - if not test then failwithf "test 183 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 184; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 184 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 185; - let test = raises in - if not test then failwithf "test 185 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0l with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 186; - let test = raises in - if not test then failwithf "test 186 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 187; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 187 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 188; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 188 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 189; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 189 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 190; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 190 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* int64 *) - (*************) - let eq = (fun a b -> Int64.equal (globalize a) (globalize b)) in - let mk_value i = Int64.of_int i in - (* 1. Create an array of size [size] *) - let a : int64 array = makearray_dynamic size 0L in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 191; - let test = eq el 0L in - if not test then failwithf "test 191 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 192; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 192 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 193; - let test = raises in - if not test then failwithf "test 193 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0L with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 194; - let test = raises in - if not test then failwithf "test 194 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 195; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 195 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 196; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 196 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 197; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 197 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 198; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 198 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*****************) - (* nativeint *) - (*****************) - let eq = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in - let mk_value i = Nativeint.of_int i in - (* 1. Create an array of size [size] *) - let a : nativeint array = makearray_dynamic size 0n in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 199; - let test = eq el 0n in - if not test then failwithf "test 199 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 200; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 200 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 201; - let test = raises in - if not test then failwithf "test 201 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0n with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 202; - let test = raises in - if not test then failwithf "test 202 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 203; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 203 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 204; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 204 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 205; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 205 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 206; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 206 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* int *) - (***********) - let eq = (fun a b -> Int.equal a b) in - let mk_value i = i in - (* 1. Create an array of size [size] *) - let a : int array = makearray_dynamic size 0 in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 207; - let test = eq el 0 in - if not test then failwithf "test 207 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 208; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 208 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 209; - let test = raises in - if not test then failwithf "test 209 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0 with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 210; - let test = raises in - if not test then failwithf "test 210 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 211; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 211 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 212; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 212 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 213; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 213 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 214; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 214 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* enum3 *) - (*************) - let eq = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in - let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in - (* 1. Create an array of size [size] *) - let a : enum3 array = makearray_dynamic size A3_0 in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 215; - let test = eq el A3_0 in - if not test then failwithf "test 215 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 216; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 216 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 217; - let test = raises in - if not test then failwithf "test 217 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i A3_0 with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 218; - let test = raises in - if not test then failwithf "test 218 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 219; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 219 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 220; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 220 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 A3_0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 221; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 221 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 A3_0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 222; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 222 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur2 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in - (* 1. Create an array of size [size] *) - let a : ur2 array = makearray_dynamic size (#{ a = #0L; b = 0 } : ur2) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 223; - let test = eq el (#{ a = #0L; b = 0 } : ur2) in - if not test then failwithf "test 223 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 224; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 224 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 225; - let test = raises in - if not test then failwithf "test 225 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L; b = 0 } : ur2) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 226; - let test = raises in - if not test then failwithf "test 226 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 227; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 227 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 228; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 228 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L; b = 0 } : ur2) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 229; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 229 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = 0 } : ur2) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 230; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 230 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**********************) - (* #(int * int64) *) - (**********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in - let mk_value i = #(i, Int64.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(int * int64) array = makearray_dynamic size #(0, 0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 231; - let test = eq el #(0, 0L) in - if not test then failwithf "test 231 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 232; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 232 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 233; - let test = raises in - if not test then failwithf "test 233 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(0, 0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 234; - let test = raises in - if not test then failwithf "test 234 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 235; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 235 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 236; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 236 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(0, 0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 237; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 237 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(0, 0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 238; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 238 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************************************************************************************************************) - (* #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) *) - (**************************************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in - let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) array = makearray_dynamic size #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 239; - let test = eq el #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - if not test then failwithf "test 239 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 240; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 240 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 241; - let test = raises in - if not test then failwithf "test 241 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 242; - let test = raises in - if not test then failwithf "test 242 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 243; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 243 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 244; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 244 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 245; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 245 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 246; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 246 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (********************************) - (* #(float * float * float) *) - (********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in - let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float * float * float) array = makearray_dynamic size #(0., 0., 0.) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 247; - let test = eq el #(0., 0., 0.) in - if not test then failwithf "test 247 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 248; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 248 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 249; - let test = raises in - if not test then failwithf "test 249 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(0., 0., 0.) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 250; - let test = raises in - if not test then failwithf "test 250 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 251; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 251 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 252; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 252 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(0., 0., 0.) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 253; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 253 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(0., 0., 0.) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 254; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 254 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************************************************************************) - (* #(float * #(float * float) * #(float * #(float * float * float))) *) - (*************************************************************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in - let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in - (* 1. Create an array of size [size] *) - let a : #(float * #(float * float) * #(float * #(float * float * float))) array = makearray_dynamic size #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 255; - let test = eq el #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - if not test then failwithf "test 255 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 256; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 256 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 257; - let test = raises in - if not test then failwithf "test 257 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(0., #(0., 0.), #(0., #(0., 0., 0.))) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 258; - let test = raises in - if not test then failwithf "test 258 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 259; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 259 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 260; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 260 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 261; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 261 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 262; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 262 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (********************************) - (* #(float# * int * int64#) *) - (********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * int * int64#) array = makearray_dynamic size #(#0., 0, #0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 263; - let test = eq el #(#0., 0, #0L) in - if not test then failwithf "test 263 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 264; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 264 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 265; - let test = raises in - if not test then failwithf "test 265 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., 0, #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 266; - let test = raises in - if not test then failwithf "test 266 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 267; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 267 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 268; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 268 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., 0, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 269; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 269 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., 0, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 270; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 270 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***************************************************************************************) - (* #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) *) - (***************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in - (* 1. Create an array of size [size] *) - let a : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) array = makearray_dynamic size #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 271; - let test = eq el #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - if not test then failwithf "test 271 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 272; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 272 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 273; - let test = raises in - if not test then failwithf "test 273 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 274; - let test = raises in - if not test then failwithf "test 274 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 275; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 275 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 276; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 276 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 277; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 277 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 278; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 278 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (********************) - (* #(ur2 * ur1) *) - (********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - (* 1. Create an array of size [size] *) - let a : #(ur2 * ur1) array = makearray_dynamic size #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 279; - let test = eq el #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - if not test then failwithf "test 279 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 280; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 280 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 281; - let test = raises in - if not test then failwithf "test 281 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 282; - let test = raises in - if not test then failwithf "test 282 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 283; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 283 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 284; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 284 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 285; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 285 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 286; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 286 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - () - -let test_makearray_dynamic_local size = - (****************) - (* float32# *) - (****************) - let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in - let mk_value i = Float32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float32# array = makearray_dynamic_local size #0.s in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 287; - let test = eq el #0.s in - if not test then failwithf "test 287 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 288; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 288 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 289; - let test = raises in - if not test then failwithf "test 289 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0.s with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 290; - let test = raises in - if not test then failwithf "test 290 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 291; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 291 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 292; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 292 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 293; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 293 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 294; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 294 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* float# *) - (**************) - let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in - let mk_value i = Float_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float# array = makearray_dynamic_local size #0. in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 295; - let test = eq el #0. in - if not test then failwithf "test 295 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 296; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 296 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 297; - let test = raises in - if not test then failwithf "test 297 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0. with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 298; - let test = raises in - if not test then failwithf "test 298 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 299; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 299 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 300; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 300 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 301; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 301 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 302; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 302 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int32# *) - (**************) - let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in - let mk_value i = Int32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int32# array = makearray_dynamic_local size #0l in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 303; - let test = eq el #0l in - if not test then failwithf "test 303 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 304; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 304 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 305; - let test = raises in - if not test then failwithf "test 305 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0l with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 306; - let test = raises in - if not test then failwithf "test 306 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 307; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 307 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 308; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 308 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 309; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 309 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 310; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 310 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int64# *) - (**************) - let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in - let mk_value i = Int64_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int64# array = makearray_dynamic_local size #0L in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 311; - let test = eq el #0L in - if not test then failwithf "test 311 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 312; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 312 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 313; - let test = raises in - if not test then failwithf "test 313 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0L with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 314; - let test = raises in - if not test then failwithf "test 314 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 315; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 315 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 316; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 316 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 317; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 317 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 318; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 318 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (******************) - (* nativeint# *) - (******************) - let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in - let mk_value i = Nativeint_u.of_int i in - (* 1. Create an array of size [size] *) - let a : nativeint# array = makearray_dynamic_local size #0n in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 319; - let test = eq el #0n in - if not test then failwithf "test 319 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 320; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 320 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 321; - let test = raises in - if not test then failwithf "test 321 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0n with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 322; - let test = raises in - if not test then failwithf "test 322 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 323; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 323 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 324; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 324 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 325; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 325 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 326; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 326 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur1 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in - (* 1. Create an array of size [size] *) - let a : ur1 array = makearray_dynamic_local size (#{ a = #0L; b = #0. } : ur1) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 327; - let test = eq el (#{ a = #0L; b = #0. } : ur1) in - if not test then failwithf "test 327 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 328; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 328 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 329; - let test = raises in - if not test then failwithf "test 329 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L; b = #0. } : ur1) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 330; - let test = raises in - if not test then failwithf "test 330 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 331; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 331 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 332; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 332 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 333; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 333 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 334; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 334 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur3 *) - (***********) - let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in - let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in - (* 1. Create an array of size [size] *) - let a : ur3 array = makearray_dynamic_local size (#{ a = #0L } : ur3) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 335; - let test = eq el (#{ a = #0L } : ur3) in - if not test then failwithf "test 335 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 336; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 336 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 337; - let test = raises in - if not test then failwithf "test 337 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L } : ur3) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 338; - let test = raises in - if not test then failwithf "test 338 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 339; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 339 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 340; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 340 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 341; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 341 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 342; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 342 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur4 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in - let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in - (* 1. Create an array of size [size] *) - let a : ur4 array = makearray_dynamic_local size (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 343; - let test = eq el (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - if not test then failwithf "test 343 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 344; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 344 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 345; - let test = raises in - if not test then failwithf "test 345 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 346; - let test = raises in - if not test then failwithf "test 346 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 347; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 347 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 348; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 348 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 349; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 349 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 350; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 350 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************************) - (* #(float# * int32# * int64#) *) - (***********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * int32# * int64#) array = makearray_dynamic_local size #(#0., #0l, #0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 351; - let test = eq el #(#0., #0l, #0L) in - if not test then failwithf "test 351 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 352; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 352 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 353; - let test = raises in - if not test then failwithf "test 353 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #0l, #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 354; - let test = raises in - if not test then failwithf "test 354 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 355; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 355 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 356; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 356 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 357; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 357 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 358; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 358 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*********************************************************************************************) - (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) - (*********************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_local size #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 359; - let test = eq el #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - if not test then failwithf "test 359 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 360; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 360 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 361; - let test = raises in - if not test then failwithf "test 361 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 362; - let test = raises in - if not test then failwithf "test 362 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 363; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 363 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 364; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 364 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 365; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 365 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 366; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 366 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************) - (* #(int64# * ur1) *) - (***********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - (* 1. Create an array of size [size] *) - let a : #(int64# * ur1) array = makearray_dynamic_local size #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 367; - let test = eq el #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - if not test then failwithf "test 367 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 368; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 368 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 369; - let test = raises in - if not test then failwithf "test 369 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 370; - let test = raises in - if not test then failwithf "test 370 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 371; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 371 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 372; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 372 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 373; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 373 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 374; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 374 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***************) - (* float32 *) - (***************) - let eq = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in - let mk_value i = Float32.of_int i in - (* 1. Create an array of size [size] *) - let a : float32 array = makearray_dynamic_local size 0.s in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 375; - let test = eq el 0.s in - if not test then failwithf "test 375 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 376; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 376 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 377; - let test = raises in - if not test then failwithf "test 377 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0.s with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 378; - let test = raises in - if not test then failwithf "test 378 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 379; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 379 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 380; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 380 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 381; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 381 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 382; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 382 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* float *) - (*************) - let eq = (fun a b -> Float.equal (globalize a) (globalize b)) in - let mk_value i = Float.of_int i in - (* 1. Create an array of size [size] *) - let a : float array = makearray_dynamic_local size 0. in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 383; - let test = eq el 0. in - if not test then failwithf "test 383 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 384; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 384 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 385; - let test = raises in - if not test then failwithf "test 385 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0. with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 386; - let test = raises in - if not test then failwithf "test 386 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 387; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 387 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 388; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 388 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 389; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 389 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 390; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 390 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* int32 *) - (*************) - let eq = (fun a b -> Int32.equal (globalize a) (globalize b)) in - let mk_value i = Int32.of_int i in - (* 1. Create an array of size [size] *) - let a : int32 array = makearray_dynamic_local size 0l in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 391; - let test = eq el 0l in - if not test then failwithf "test 391 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 392; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 392 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 393; - let test = raises in - if not test then failwithf "test 393 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0l with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 394; - let test = raises in - if not test then failwithf "test 394 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 395; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 395 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 396; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 396 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 397; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 397 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 398; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 398 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* int64 *) - (*************) - let eq = (fun a b -> Int64.equal (globalize a) (globalize b)) in - let mk_value i = Int64.of_int i in - (* 1. Create an array of size [size] *) - let a : int64 array = makearray_dynamic_local size 0L in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 399; - let test = eq el 0L in - if not test then failwithf "test 399 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 400; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 400 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 401; - let test = raises in - if not test then failwithf "test 401 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0L with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 402; - let test = raises in - if not test then failwithf "test 402 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 403; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 403 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 404; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 404 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 405; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 405 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 406; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 406 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*****************) - (* nativeint *) - (*****************) - let eq = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in - let mk_value i = Nativeint.of_int i in - (* 1. Create an array of size [size] *) - let a : nativeint array = makearray_dynamic_local size 0n in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 407; - let test = eq el 0n in - if not test then failwithf "test 407 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 408; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 408 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 409; - let test = raises in - if not test then failwithf "test 409 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0n with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 410; - let test = raises in - if not test then failwithf "test 410 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 411; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 411 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 412; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 412 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 413; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 413 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 414; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 414 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* int *) - (***********) - let eq = (fun a b -> Int.equal a b) in - let mk_value i = i in - (* 1. Create an array of size [size] *) - let a : int array = makearray_dynamic_local size 0 in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 415; - let test = eq el 0 in - if not test then failwithf "test 415 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 416; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 416 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 417; - let test = raises in - if not test then failwithf "test 417 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i 0 with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 418; - let test = raises in - if not test then failwithf "test 418 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 419; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 419 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 420; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 420 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 421; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 421 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 422; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 422 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************) - (* enum3 *) - (*************) - let eq = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in - let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in - (* 1. Create an array of size [size] *) - let a : enum3 array = makearray_dynamic_local size A3_0 in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 423; - let test = eq el A3_0 in - if not test then failwithf "test 423 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 424; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 424 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 425; - let test = raises in - if not test then failwithf "test 425 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i A3_0 with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 426; - let test = raises in - if not test then failwithf "test 426 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 427; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 427 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 428; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 428 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 A3_0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 429; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 429 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 A3_0 in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 430; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 430 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur2 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in - (* 1. Create an array of size [size] *) - let a : ur2 array = makearray_dynamic_local size (#{ a = #0L; b = 0 } : ur2) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 431; - let test = eq el (#{ a = #0L; b = 0 } : ur2) in - if not test then failwithf "test 431 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 432; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 432 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 433; - let test = raises in - if not test then failwithf "test 433 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L; b = 0 } : ur2) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 434; - let test = raises in - if not test then failwithf "test 434 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 435; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 435 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 436; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 436 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L; b = 0 } : ur2) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 437; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 437 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = 0 } : ur2) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 438; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 438 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**********************) - (* #(int * int64) *) - (**********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in - let mk_value i = #(i, Int64.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(int * int64) array = makearray_dynamic_local size #(0, 0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 439; - let test = eq el #(0, 0L) in - if not test then failwithf "test 439 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 440; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 440 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 441; - let test = raises in - if not test then failwithf "test 441 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(0, 0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 442; - let test = raises in - if not test then failwithf "test 442 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 443; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 443 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 444; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 444 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(0, 0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 445; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 445 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(0, 0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 446; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 446 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************************************************************************************************************) - (* #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) *) - (**************************************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in - let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) array = makearray_dynamic_local size #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 447; - let test = eq el #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - if not test then failwithf "test 447 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 448; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 448 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 449; - let test = raises in - if not test then failwithf "test 449 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 450; - let test = raises in - if not test then failwithf "test 450 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 451; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 451 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 452; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 452 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 453; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 453 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 454; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 454 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (********************************) - (* #(float * float * float) *) - (********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in - let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float * float * float) array = makearray_dynamic_local size #(0., 0., 0.) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 455; - let test = eq el #(0., 0., 0.) in - if not test then failwithf "test 455 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 456; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 456 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 457; - let test = raises in - if not test then failwithf "test 457 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(0., 0., 0.) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 458; - let test = raises in - if not test then failwithf "test 458 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 459; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 459 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 460; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 460 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(0., 0., 0.) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 461; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 461 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(0., 0., 0.) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 462; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 462 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*************************************************************************) - (* #(float * #(float * float) * #(float * #(float * float * float))) *) - (*************************************************************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in - let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in - (* 1. Create an array of size [size] *) - let a : #(float * #(float * float) * #(float * #(float * float * float))) array = makearray_dynamic_local size #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 463; - let test = eq el #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - if not test then failwithf "test 463 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 464; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 464 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 465; - let test = raises in - if not test then failwithf "test 465 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(0., #(0., 0.), #(0., #(0., 0., 0.))) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 466; - let test = raises in - if not test then failwithf "test 466 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 467; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 467 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 468; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 468 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 469; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 469 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 470; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 470 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (********************************) - (* #(float# * int * int64#) *) - (********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * int * int64#) array = makearray_dynamic_local size #(#0., 0, #0L) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 471; - let test = eq el #(#0., 0, #0L) in - if not test then failwithf "test 471 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 472; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 472 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 473; - let test = raises in - if not test then failwithf "test 473 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., 0, #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 474; - let test = raises in - if not test then failwithf "test 474 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 475; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 475 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 476; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 476 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., 0, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 477; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 477 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., 0, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 478; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 478 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***************************************************************************************) - (* #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) *) - (***************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in - (* 1. Create an array of size [size] *) - let a : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) array = makearray_dynamic_local size #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 479; - let test = eq el #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - if not test then failwithf "test 479 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 480; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 480 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 481; - let test = raises in - if not test then failwithf "test 481 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 482; - let test = raises in - if not test then failwithf "test 482 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 483; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 483 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 484; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 484 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 485; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 485 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 486; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 486 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (********************) - (* #(ur2 * ur1) *) - (********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - (* 1. Create an array of size [size] *) - let a : #(ur2 * ur1) array = makearray_dynamic_local size #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - mark_test_run 487; - let test = eq el #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - if not test then failwithf "test 487 failed %d %d" size i; - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 488; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 488 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 489; - let test = raises in - if not test then failwithf "test 489 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 490; - let test = raises in - if not test then failwithf "test 490 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 491; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 491 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 492; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 492 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 493; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 493 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 494; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 494 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - () - -let test_makearray_dynamic_uninit size = - (****************) - (* float32# *) - (****************) - let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in - let mk_value i = Float32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float32# array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 495; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 495 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 496; - let test = raises in - if not test then failwithf "test 496 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0.s with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 497; - let test = raises in - if not test then failwithf "test 497 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 498; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 498 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 499; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 499 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 500; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 500 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 501; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 501 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* float# *) - (**************) - let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in - let mk_value i = Float_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float# array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 502; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 502 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 503; - let test = raises in - if not test then failwithf "test 503 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0. with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 504; - let test = raises in - if not test then failwithf "test 504 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 505; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 505 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 506; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 506 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 507; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 507 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 508; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 508 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int32# *) - (**************) - let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in - let mk_value i = Int32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int32# array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 509; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 509 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 510; - let test = raises in - if not test then failwithf "test 510 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0l with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 511; - let test = raises in - if not test then failwithf "test 511 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 512; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 512 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 513; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 513 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 514; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 514 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 515; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 515 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int64# *) - (**************) - let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in - let mk_value i = Int64_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int64# array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 516; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 516 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 517; - let test = raises in - if not test then failwithf "test 517 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0L with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 518; - let test = raises in - if not test then failwithf "test 518 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 519; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 519 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 520; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 520 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 521; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 521 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 522; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 522 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (******************) - (* nativeint# *) - (******************) - let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in - let mk_value i = Nativeint_u.of_int i in - (* 1. Create an array of size [size] *) - let a : nativeint# array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 523; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 523 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 524; - let test = raises in - if not test then failwithf "test 524 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0n with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 525; - let test = raises in - if not test then failwithf "test 525 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 526; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 526 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 527; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 527 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 528; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 528 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 529; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 529 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur1 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in - (* 1. Create an array of size [size] *) - let a : ur1 array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 530; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 530 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 531; - let test = raises in - if not test then failwithf "test 531 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L; b = #0. } : ur1) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 532; - let test = raises in - if not test then failwithf "test 532 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 533; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 533 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 534; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 534 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 535; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 535 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 536; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 536 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur3 *) - (***********) - let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in - let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in - (* 1. Create an array of size [size] *) - let a : ur3 array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 537; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 537 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 538; - let test = raises in - if not test then failwithf "test 538 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L } : ur3) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 539; - let test = raises in - if not test then failwithf "test 539 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 540; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 540 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 541; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 541 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 542; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 542 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 543; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 543 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur4 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in - let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in - (* 1. Create an array of size [size] *) - let a : ur4 array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 544; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 544 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 545; - let test = raises in - if not test then failwithf "test 545 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 546; - let test = raises in - if not test then failwithf "test 546 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 547; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 547 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 548; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 548 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 549; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 549 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 550; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 550 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************************) - (* #(float# * int32# * int64#) *) - (***********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * int32# * int64#) array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 551; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 551 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 552; - let test = raises in - if not test then failwithf "test 552 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #0l, #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 553; - let test = raises in - if not test then failwithf "test 553 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 554; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 554 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 555; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 555 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 556; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 556 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 557; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 557 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*********************************************************************************************) - (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) - (*********************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 558; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 558 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 559; - let test = raises in - if not test then failwithf "test 559 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 560; - let test = raises in - if not test then failwithf "test 560 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 561; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 561 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 562; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 562 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 563; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 563 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 564; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 564 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************) - (* #(int64# * ur1) *) - (***********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - (* 1. Create an array of size [size] *) - let a : #(int64# * ur1) array = makearray_dynamic_uninit size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 565; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 565 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 566; - let test = raises in - if not test then failwithf "test 566 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 567; - let test = raises in - if not test then failwithf "test 567 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 568; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 568 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 569; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 569 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 570; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 570 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 571; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 571 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - () - -let test_makearray_dynamic_uninit_local size = - (****************) - (* float32# *) - (****************) - let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in - let mk_value i = Float32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float32# array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 572; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 572 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 573; - let test = raises in - if not test then failwithf "test 573 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0.s with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 574; - let test = raises in - if not test then failwithf "test 574 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 575; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 575 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 576; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 576 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 577; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 577 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0.s in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 578; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 578 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* float# *) - (**************) - let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in - let mk_value i = Float_u.of_int i in - (* 1. Create an array of size [size] *) - let a : float# array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 579; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 579 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 580; - let test = raises in - if not test then failwithf "test 580 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0. with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 581; - let test = raises in - if not test then failwithf "test 581 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 582; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 582 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 583; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 583 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 584; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 584 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0. in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 585; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 585 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int32# *) - (**************) - let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in - let mk_value i = Int32_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int32# array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 586; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 586 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 587; - let test = raises in - if not test then failwithf "test 587 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0l with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 588; - let test = raises in - if not test then failwithf "test 588 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 589; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 589 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 590; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 590 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 591; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 591 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0l in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 592; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 592 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (**************) - (* int64# *) - (**************) - let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in - let mk_value i = Int64_u.of_int i in - (* 1. Create an array of size [size] *) - let a : int64# array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 593; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 593 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 594; - let test = raises in - if not test then failwithf "test 594 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0L with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 595; - let test = raises in - if not test then failwithf "test 595 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 596; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 596 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 597; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 597 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 598; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 598 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0L in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 599; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 599 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (******************) - (* nativeint# *) - (******************) - let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in - let mk_value i = Nativeint_u.of_int i in - (* 1. Create an array of size [size] *) - let a : nativeint# array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 600; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 600 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 601; - let test = raises in - if not test then failwithf "test 601 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #0n with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 602; - let test = raises in - if not test then failwithf "test 602 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 603; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 603 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 604; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 604 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 605; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 605 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #0n in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 606; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 606 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur1 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in - let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in - (* 1. Create an array of size [size] *) - let a : ur1 array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 607; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 607 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 608; - let test = raises in - if not test then failwithf "test 608 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L; b = #0. } : ur1) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 609; - let test = raises in - if not test then failwithf "test 609 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 610; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 610 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 611; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 611 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 612; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 612 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 613; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 613 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur3 *) - (***********) - let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in - let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in - (* 1. Create an array of size [size] *) - let a : ur3 array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 614; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 614 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 615; - let test = raises in - if not test then failwithf "test 615 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = #0L } : ur3) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 616; - let test = raises in - if not test then failwithf "test 616 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 617; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 617 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 618; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 618 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 619; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 619 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 620; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 620 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********) - (* ur4 *) - (***********) - let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in - let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in - (* 1. Create an array of size [size] *) - let a : ur4 array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 621; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 621 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 622; - let test = raises in - if not test then failwithf "test 622 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 623; - let test = raises in - if not test then failwithf "test 623 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 624; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 624 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 625; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 625 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 626; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 626 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 627; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 627 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************************) - (* #(float# * int32# * int64#) *) - (***********************************) - let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in - let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * int32# * int64#) array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 628; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 628 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 629; - let test = raises in - if not test then failwithf "test 629 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #0l, #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 630; - let test = raises in - if not test then failwithf "test 630 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 631; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 631 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 632; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 632 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 633; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 633 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 634; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 634 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (*********************************************************************************************) - (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) - (*********************************************************************************************) - let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in - let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in - (* 1. Create an array of size [size] *) - let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 635; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 635 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 636; - let test = raises in - if not test then failwithf "test 636 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 637; - let test = raises in - if not test then failwithf "test 637 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 638; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 638 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 639; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 639 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 640; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 640 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 641; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 641 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - (***********************) - (* #(int64# * ur1) *) - (***********************) - let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in - let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in - (* 1. Create an array of size [size] *) - let a : #(int64# * ur1) array = makearray_dynamic_uninit_local size in - (* 2. For uninitialized arrays, element values are unspecified *) - (* 2. For initialized arrays, check all elements have the correct value *) - for i = 0 to size - 1 do - let el = get a i in - let _ = el in () - done; - (* 3. Fill [a] with distinct values and read back those values *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - Gc.compact (); - for i = 0 to size - 1 do - mark_test_run 642; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 642 failed %d %d" size i; - done; - iter (bad_indices size) ~f:(fun i -> - (* 4. Getting bad indices errors *) - let raises = - match get a i with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 643; - let test = raises in - if not test then failwithf "test 643 failed %d %d" size i; - (* 5. Setting bad indices errors *) - let raises = - match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with - | exception Invalid_argument _ -> true - | _ -> false - in - mark_test_run 644; - let test = raises in - if not test then failwithf "test 644 failed %d %d" size i; - ) [@nontail]; - Gc.compact (); - (* 6. Array contents were unaffacted by setting bad indices *) - for i = 0 to size - 1 do - mark_test_run 645; - let test = eq (get a i) (mk_value i) in - if not test then failwithf "test 645 failed %d %d" size i; - done; - (* 7. Overlapping blits *) - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> - unsafe_blit a ofs1 a ofs2 len; - for i = 0 to size - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i - in - mark_test_run 646; - let test = eq (get a i) (mk_value expected_src_i) in - if not test then failwithf "test 646 failed %d %d %d %d %d" size ofs1 ofs2 len i; - done; - (* Reset array *) - for i = 0 to size - 1 do - set a i (mk_value i); - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 8. Blits to heap arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 647; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 647 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - (* 9. Blits to local arrays *) - iter (sizes) ~f:(fun size2 -> - iter (blit_offsets size) ~f:(fun ofs1 -> - iter (blit_offsets size2) ~f:(fun ofs2 -> - iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> - let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in - unsafe_blit a ofs1 a2 ofs2 len; - for i = 0 to size2 - 1 do - let expected_src_i = - if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 - in - mark_test_run 648; - let test = eq (get a2 i) (mk_value expected_src_i) in - if not test then failwithf "test 648 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; - done; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - ) [@nontail]; - Gc.compact (); - - () - -(* Main tests *) -let () = - print_endline "test_makearray_dynamic"; - iter sizes ~f:test_makearray_dynamic; - print_endline "test_makearray_dynamic_local"; - iter sizes ~f:test_makearray_dynamic_local; - print_endline "test_makearray_dynamic_uninit"; - iter sizes ~f:test_makearray_dynamic_uninit; - print_endline "test_makearray_dynamic_uninit_local"; - iter sizes ~f:test_makearray_dynamic_uninit_local; - () -;; - -for i = 1 to 648 do - if not (List.mem ~set:!tests_run i) then failwithf "test %d not run" i -done;; -let () = Printf.printf "All tests passed.%!\n";; diff --git a/testsuite/tests/typing-layouts-arrays/generated_test.reference b/testsuite/tests/typing-layouts-arrays/generated_test.reference deleted file mode 100644 index c2075fa9659..00000000000 --- a/testsuite/tests/typing-layouts-arrays/generated_test.reference +++ /dev/null @@ -1,5 +0,0 @@ -test_makearray_dynamic -test_makearray_dynamic_local -test_makearray_dynamic_uninit -test_makearray_dynamic_uninit_local -All tests passed. diff --git a/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml b/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml deleted file mode 100644 index 3dd358ae67c..00000000000 --- a/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* TEST - readonly_files = "generate_makearray_dynamic_tests.ml"; - (* Generate the bytecode/native code versions of - [generate_makearray_dynamic_tests.ml]. This doesn't actually run the test; - it just updates the generated test program (which is separately - run by the test harness). - *) - - { - setup-ocamlopt.opt-build-env; - stack-allocation; - program = "${test_source_directory}/generate.out"; - all_modules = "generate_makearray_dynamic_tests.ml"; - include stdlib_stable; - include stdlib_upstream_compatible; - ocamlopt.opt; - arguments = "native"; - output = "${test_source_directory}/generated_test.ml.corrected"; - run; - output = "${test_source_directory}/generated_test.ml.corrected"; - reference = "${test_source_directory}/generated_test.ml"; - check-program-output; - } -*) diff --git a/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml b/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml deleted file mode 100644 index 81dd9df04e0..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = float -type unboxed_t = float# - -let elem : boxed_t elem = float_elem -let words_wide : int = 1 -let zero () : unboxed_t = #0. - -let to_boxed a = Float_u.to_float a -let of_boxed a = Float_u.of_float a - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module Float_u_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic : int -> element_t -> element_t array = - "%makearray_dynamic" - - let unsafe_create : int -> element_t array = - (* We don't actually have an uninitialized creation function for these, yet, - so we just use [makearray_dynamic] (which is what we want to test anyway) - with the zero element. *) - fun i -> makearray_dynamic i (zero ()) - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module Float_u_array = Gen_u_array.Make (Float_u_array0) - -module Float_u_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = Float_u_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (Float_u_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml deleted file mode 100644 index 05b59f4ee0b..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = float * int * int64 -type unboxed_t = #(float# * int * int64#) - -let elem : boxed_t elem = Tup3 (float_elem, int_elem, int64_elem) -let words_wide : int = 3 -let zero () : unboxed_t = #(#0., 0, #0L) - -let to_boxed #(a, b, c) = (Float_u.to_float a, b, Int64_u.to_int64 c) -let of_boxed (a, b, c) = #(Float_u.of_float a, b, Int64_u.of_int64 c) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic : int -> element_t -> element_t array = - "%makearray_dynamic" - - let unsafe_create : int -> element_t array = - (* We don't actually have an uninitialized creation function for these, yet, - so we just use [makearray_dynamic] (which is what we want to test anyway) - with the zero element. *) - fun i -> makearray_dynamic i (zero ()) - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml deleted file mode 100644 index 4ce8c2a43d5..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml +++ /dev/null @@ -1,114 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = - float * (int * int64) * float32 * (int32 * (float32 * float)) * int -type unboxed_t = - #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) - * int) - -let elem : boxed_t elem = - Tup5 (float_elem, - Tup2 (int_elem, int64_elem), - float32_elem, - Tup2 (int32_elem, (Tup2 (float32_elem, float_elem))), - int_elem) - -let words_wide : int = 8 -let zero () : unboxed_t = - #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) - -let to_boxed #(a, #(b, c), d, #(e, #(f, g)), h) = - (Float_u.to_float a, - (b, Int64_u.to_int64 c), - Float32_u.to_float32 d, - (Int32_u.to_int32 e, (Float32_u.to_float32 f, Float_u.to_float g)), - h) - -let of_boxed (a, (b, c), d, (e, (f, g)), h) = - #(Float_u.of_float a, - #(b, Int64_u.of_int64 c), - Float32_u.of_float32 d, - #(Int32_u.of_int32 e, #(Float32_u.of_float32 f, Float_u.of_float g)), - h) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic : int -> element_t -> element_t array = - "%makearray_dynamic" - - let unsafe_create : int -> element_t array = - (* We don't actually have an uninitialized creation function for these, yet, - so we just use [makearray_dynamic] (which is what we want to test anyway) - with the zero element. *) - fun i -> makearray_dynamic i (zero ()) - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml deleted file mode 100644 index 4dc10e586f7..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml +++ /dev/null @@ -1,90 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = float * int32 * int64 -type unboxed_t = #(float# * int32# * int64#) - -let elem : boxed_t elem = Tup3 (float_elem, int32_elem, int64_elem) -let words_wide : int = 3 -let zero () : unboxed_t = #(#0., #0l, #0L) - -let to_boxed #(a, b, c) = (Float_u.to_float a, Int32_u.to_int32 b, Int64_u.to_int64 c) -let of_boxed (a, b, c) = #(Float_u.of_float a, Int32_u.of_int32 b, Int64_u.of_int64 c) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic_uninit : int -> element_t array = - "%makearray_dynamic_uninit" - - let unsafe_create : int -> element_t array = - fun i -> makearray_dynamic_uninit i - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml deleted file mode 100644 index 1381e82f68e..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml +++ /dev/null @@ -1,111 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = - float * (int64 * int64) * float32 * (int32 * (float32 * float)) * int64 -type unboxed_t = - #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) - * int64#) - -let elem : boxed_t elem = - Tup5 (float_elem, - Tup2 (int64_elem, int64_elem), - float32_elem, - Tup2 (int32_elem, (Tup2 (float32_elem, float_elem))), - int64_elem) - -let words_wide : int = 8 -let zero () : unboxed_t = - #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) - -let to_boxed #(a, #(b, c), d, #(e, #(f, g)), h) = - (Float_u.to_float a, - (Int64_u.to_int64 b, Int64_u.to_int64 c), - Float32_u.to_float32 d, - (Int32_u.to_int32 e, (Float32_u.to_float32 f, Float_u.to_float g)), - Int64_u.to_int64 h) - -let of_boxed (a, (b, c), d, (e, (f, g)), h) = - #(Float_u.of_float a, - #(Int64_u.of_int64 b, Int64_u.of_int64 c), - Float32_u.of_float32 d, - #(Int32_u.of_int32 e, #(Float32_u.of_float32 f, Float_u.of_float g)), - Int64_u.of_int64 h) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic_uninit : int -> element_t array = - "%makearray_dynamic_uninit" - - let unsafe_create : int -> element_t array = - fun i -> makearray_dynamic_uninit i - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml deleted file mode 100644 index 33daf2c9485..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml +++ /dev/null @@ -1,94 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - stack-allocation; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = int * int64 -type unboxed_t = #(int * int64) - -let elem : boxed_t elem = Tup2 (int_elem, int64_elem) -let words_wide : int = 2 -let zero () : unboxed_t = #(0, 0L) - -let to_boxed #(i, i64) = (i, i64) -let of_boxed (i, i64) = #(i, i64) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic : int -> element_t -> element_t array = - "%makearray_dynamic" - - let unsafe_create : int -> element_t array = - (* We don't actually have an uninitialized creation function for these, yet, - so we just use [makearray_dynamic] (which is what we want to test anyway) - with the zero element. *) - fun i -> makearray_dynamic i (zero ()) - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml deleted file mode 100644 index 1d64378a6ba..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - stack-allocation; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = - int64 option - * (int * int32 * float) - * float - * (float32 * (nativeint * nativeint) option) - * int32 - -type unboxed_t = - #(int64 option - * #(int * int32 * float) - * float - * #(float32 * (nativeint * nativeint) option) - * int32) - -let elem : boxed_t elem = - Tup5 (Option int64_elem, - Tup3 (int_elem, int32_elem, float_elem), - float_elem, - Tup2 (float32_elem, Option (Tup2 (nativeint_elem, nativeint_elem))), - int32_elem) - -let words_wide : int = 8 -let zero () : unboxed_t = - #(Some 0L, - #(0, 0l, 0.), - 0., - #(0.s, Some (0n, 0n)), - 0l) - -let to_boxed #(a, #(b, c, d), e, #(f, g), h) = (a, (b, c, d), e, (f, g), h) -let of_boxed (a, (b, c, d), e, (f, g), h) = #(a, #(b, c, d), e, #(f, g), h) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic : int -> element_t -> element_t array = - "%makearray_dynamic" - - let unsafe_create : int -> element_t array = - (* We don't actually have an uninitialized creation function for these, yet, - so we just use [makearray_dynamic] (which is what we want to test anyway) - with the zero element. *) - fun i -> makearray_dynamic i (zero ()) - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml deleted file mode 100644 index b18e167c7aa..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml +++ /dev/null @@ -1,96 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - stack-allocation; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = float * float * float - -type unboxed_t = #(float * float * float) - -let elem : boxed_t elem = Tup3 (float_elem, float_elem, float_elem) - -let words_wide : int = 3 -let zero () : unboxed_t = #(0., 0., 0.) - -let to_boxed #(a, b, c) = a, b, c -let of_boxed (a, b, c) = #(a, b, c) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic : int -> element_t -> element_t array = - "%makearray_dynamic" - - let unsafe_create : int -> element_t array = - (* We don't actually have an uninitialized creation function for these, yet, - so we just use [makearray_dynamic] (which is what we want to test anyway) - with the zero element. *) - fun i -> makearray_dynamic i (zero ()) - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml deleted file mode 100644 index 19aa03f400a..00000000000 --- a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml +++ /dev/null @@ -1,100 +0,0 @@ -(* TEST - include stdlib_stable; - include stdlib_upstream_compatible; - readonly_files = - "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; - modules = "${readonly_files}"; - flambda2; - stack-allocation; - arch_amd64; - { - flags = "-extension layouts_beta"; - bytecode; - } - { - flags = "-extension layouts_beta"; - native; - } -*) - -(* CR mshinwell: enable for arm64 once float32 is available *) - -open Gen_product_array_helpers -open Stdlib_stable -open Stdlib_upstream_compatible - -(* If copying this test for a new product shape, you should only have to - change the bit between here and the next comment. See README.md in this - test directory. *) -type boxed_t = float * (float * float) * (float * (float * float * float)) - -type unboxed_t = - #(float * #(float * float) * #(float * #(float * float * float))) - -let elem : boxed_t elem = - Tup3 (float_elem, - Tup2 (float_elem, float_elem), - Tup2 (float_elem, Tup3 (float_elem, float_elem, float_elem))) - -let words_wide : int = 7 -let zero () : unboxed_t = #(0., #(0., 0.), #(0., #(0., 0., 0.))) - -let to_boxed #(a, #(b, c), #(d, #(e, f, g))) = a, (b, c), (d, (e, f, g)) -let of_boxed (a, (b, c), (d, (e, f, g))) = #(a, #(b, c), #(d, #(e, g, f))) - -(* Below here is copy pasted due to the absence of layout polymorphism. Don't - change it. See README.md in this test directory. *) -module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) - -module UTuple_array0 : - Gen_u_array.S0 with type element_t = unboxed_t - and type ('a : any) array_t = 'a array = struct - type element_t = unboxed_t - - type ('a : any) array_t = 'a array - - type element_arg = unit -> element_t - type t = element_t array - let max_length = Sys.max_array_length - external length : element_t array -> int = "%array_length" - external get: element_t array -> int -> element_t = "%array_safe_get" - let get t i = let a = get t i in fun () -> a - external set: element_t array -> int -> element_t -> unit = "%array_safe_set" - let set t i e = set t i (e ()) - external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" - let unsafe_get t i = let a = unsafe_get t i in fun () -> a - external unsafe_set: element_t array -> int -> element_t -> unit = - "%array_unsafe_set" - let unsafe_set t i e = unsafe_set t i (e ()) - - external makearray_dynamic : int -> element_t -> element_t array = - "%makearray_dynamic" - - let unsafe_create : int -> element_t array = - (* We don't actually have an uninitialized creation function for these, yet, - so we just use [makearray_dynamic] (which is what we want to test anyway) - with the zero element. *) - fun i -> makearray_dynamic i (zero ()) - - external unsafe_blit : - element_t array -> int -> element_t array -> int -> int -> unit = - "%arrayblit" - - let empty () : unboxed_t array = [||] - let to_boxed = to_boxed - - let compare_element x y = - Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) -end - -module UTuple_array = Gen_u_array.Make (UTuple_array0) - -module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct - module M = UTuple_array - module I = Element_ops - module E = struct - let to_boxed x = to_boxed (x ()) - let of_boxed x () = of_boxed x - end - end) -module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-products/basics.ml b/testsuite/tests/typing-layouts-products/basics.ml index efb651516c7..8f70d0b47ed 100644 --- a/testsuite/tests/typing-layouts-products/basics.ml +++ b/testsuite/tests/typing-layouts-products/basics.ml @@ -1,6 +1,9 @@ (* TEST flambda2; include stdlib_upstream_compatible; + { + expect; + } { flags = "-extension layouts_beta"; expect; @@ -783,7 +786,13 @@ type t4 = #(string * #(float# * bool option)) array arrays to beta. *) let _ = [| #(1,2) |] [%%expect{| -- : #(int * int) array = [|#(1, 2)|] +Line 1, characters 8-20: +1 | let _ = [| #(1,2) |] + ^^^^^^^^^^^^ +Error: Non-value layout value & value detected as sort for type #(int * int), + but this requires extension layouts_alpha, which is not enabled. + If you intended to use this layout, please add this flag to your build file. + Otherwise, please report this error to the Jane Street compilers team. |}] let _ = Array.init 3 (fun _ -> #(1,2)) @@ -827,7 +836,13 @@ let f x : #(int * int) = array_get x 3 [%%expect{| external array_get : ('a : any_non_null). 'a array -> int -> 'a = "%array_safe_get" [@@layout_poly] -val f : #(int * int) array -> #(int * int) = +Line 3, characters 25-38: +3 | let f x : #(int * int) = array_get x 3 + ^^^^^^^^^^^^^ +Error: Non-value layout value & value detected as sort for type #(int * int), + but this requires extension layouts_alpha, which is not enabled. + If you intended to use this layout, please add this flag to your build file. + Otherwise, please report this error to the Jane Street compilers team. |}] external[@layout_poly] array_set : ('a : any_non_null) . 'a array -> int -> 'a -> unit = @@ -836,7 +851,13 @@ let f x = array_set x 3 #(1,2) [%%expect{| external array_set : ('a : any_non_null). 'a array -> int -> 'a -> unit = "%array_safe_set" [@@layout_poly] -val f : #(int * int) array -> unit = +Line 3, characters 10-30: +3 | let f x = array_set x 3 #(1,2) + ^^^^^^^^^^^^^^^^^^^^ +Error: Non-value layout value & value detected as sort for type #(int * int), + but this requires extension layouts_alpha, which is not enabled. + If you intended to use this layout, please add this flag to your build file. + Otherwise, please report this error to the Jane Street compilers team. |}] diff --git a/testsuite/tests/typing-layouts-products/product_arrays.ml b/testsuite/tests/typing-layouts-products/product_arrays.ml index a8765e1c10b..2aaeeeec00e 100644 --- a/testsuite/tests/typing-layouts-products/product_arrays.ml +++ b/testsuite/tests/typing-layouts-products/product_arrays.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; + flags = "-extension layouts_alpha"; { expect; } @@ -13,7 +13,7 @@ (* CR layouts v7.1: The PR with middle-end support for product arrays can move this test to beta. *) -(* CR layouts v7.1: Everywhere this file says "any" it should instead +(* CR layouts v7.1: Everywhere this file says "any_non_null" it should instead say any. This is caused by [any] meaning different things alpha and beta - we can fix it when we move this test to beta. *) @@ -1864,8 +1864,10 @@ external blit_scannable : #(int * float * string) array -> int -> #(int * float * string) array -> int -> int -> unit = "%arrayblit" val blit_scannable_app : - #(int * float * string) array -> - 'a -> #(int * float * string) array -> int -> int -> unit = + ('a : value_or_null). + #(int * float * string) array -> + 'a -> #(int * float * string) array -> int -> int -> unit = + external blit_ignorable : #(float# * int * int64# * bool) array -> int -> #(float# * int * int64# * bool) array -> int -> int -> unit diff --git a/testsuite/tests/typing-layouts-products/product_iarrays.ml b/testsuite/tests/typing-layouts-products/product_iarrays.ml index 261b8950263..82773c9e516 100644 --- a/testsuite/tests/typing-layouts-products/product_iarrays.ml +++ b/testsuite/tests/typing-layouts-products/product_iarrays.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; + flags = "-extension layouts_alpha"; { expect; } diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml index 1152e2d3528..f48ce4c38d0 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml @@ -813,7 +813,13 @@ type array_record = #{ i1 : int; i2 : int } let _ = [| #{ i1 = 1; i2 = 2 } |] [%%expect{| type array_record = #{ i1 : int; i2 : int; } -- : array_record array = [|#{i1 = 1; i2 = 2}|] +Line 2, characters 8-33: +2 | let _ = [| #{ i1 = 1; i2 = 2 } |] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Non-value layout value & value detected as sort for type array_record, + but this requires extension layouts_alpha, which is not enabled. + If you intended to use this layout, please add this flag to your build file. + Otherwise, please report this error to the Jane Street compilers team. |}] type array_init_record = #{ i1 : int; i2 : int } diff --git a/testsuite/tests/typing-layouts/layout_poly.ml b/testsuite/tests/typing-layouts/layout_poly.ml index 8037325d149..acbd1dd0d0c 100644 --- a/testsuite/tests/typing-layouts/layout_poly.ml +++ b/testsuite/tests/typing-layouts/layout_poly.ml @@ -1,6 +1,10 @@ (* TEST include stdlib_upstream_compatible; { + flags = "-extension layouts"; + expect; + }{ + flags = "-extension layouts_beta"; expect; } *) @@ -711,8 +715,8 @@ Error: "[@layout_poly]" on this external declaration has no variable for it to operate on. |}] -(********************************************************) -(* Newer prims are gated to appropriate maturity levels *) +(***********************************************) +(* New untested array prims are gated to alpha *) external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = "%makearray_dynamic" @@ -720,7 +724,7 @@ external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a Lines 1-2, characters 0-22: 1 | external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = 2 | "%makearray_dynamic" -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used |}] external[@layout_poly] arrayblit : @@ -731,14 +735,5 @@ Lines 1-3, characters 0-14: 1 | external[@layout_poly] arrayblit : 2 | ('a : any_non_null). 'a array -> int -> 'a array -> int -> int -> unit = 3 | "%arrayblit" -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] - -external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = - "%makearray_dynamic_uninit" -[%%expect{| -Lines 1-2, characters 0-29: -1 | external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = -2 | "%makearray_dynamic_uninit" -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used |}] diff --git a/typing/primitive.ml b/typing/primitive.ml index 272b58674af..d2cc075844f 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -674,12 +674,6 @@ let prim_has_valid_reprs ~loc prim = any; is (Same_as_ocaml_repr C.value); ] - | "%makearray_dynamic_uninit" -> - (* Restrictions on this primitive are checked in [Translprim] *) - check [ - is (Same_as_ocaml_repr C.value); - is (Same_as_ocaml_repr C.value); - ] | "%box_float" -> exactly [Same_as_ocaml_repr C.float64; Same_as_ocaml_repr C.value] diff --git a/typing/typeopt.ml b/typing/typeopt.ml index c20a17830fc..a314ab84e5a 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -228,7 +228,7 @@ let array_kind_of_elt ~elt_sort env loc ty = (type_legacy_sort ~why:Array_element env loc ty) in let classify_product ty sorts = - if Language_extension.(is_at_least Layouts Beta) then + if Language_extension.(is_at_least Layouts Alpha) then if is_always_gc_ignorable env ty then Pgcignorableproductarray (ignorable_product_array_kind loc sorts) else From 862ced26837f2b8d9c76af8edab7509708ec39d5 Mon Sep 17 00:00:00 2001 From: dkalinichenko-js <118547217+dkalinichenko-js@users.noreply.github.com> Date: Thu, 26 Dec 2024 15:20:06 -0500 Subject: [PATCH 07/30] Add `Variant_with_null` and `Null` variant constructors (#2870) * `Variant_with_null` * `Null` tagged constructors * precise value kind * No private re-export --------- Co-authored-by: Diana Kalinichenko --- lambda/matching.ml | 8 +++++-- lambda/translcore.ml | 17 +++++++++---- lambda/value_rec_compiler.ml | 3 ++- .../lambda_to_flambda_primitives.ml | 8 +++++-- .../tests/typing-layouts-or-null/reexport.ml | 14 +++++++++++ toplevel/genprintval.ml | 4 ++++ toplevel/topdirs.ml | 2 +- typing/datarepr.ml | 14 +++++++++-- typing/includecore.ml | 12 +++++++++- typing/includecore.mli | 1 + typing/oprint.ml | 8 ++++++- typing/outcometree.mli | 1 + typing/parmatch.ml | 4 ++-- typing/predef.ml | 2 ++ typing/printtyp.ml | 24 ++++++++++++++----- typing/printtyped.ml | 2 ++ typing/typecore.ml | 8 +++++-- typing/typedecl.ml | 8 +++++-- typing/typedtree.ml | 5 ++++ typing/typeopt.ml | 11 +++++++++ typing/types.ml | 20 ++++++++++------ typing/types.mli | 6 +++++ typing/value_rec_check.ml | 2 +- 23 files changed, 150 insertions(+), 34 deletions(-) diff --git a/lambda/matching.ml b/lambda/matching.ml index 4fec43277d4..09357f8d312 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -1965,6 +1965,8 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = cstr.cstr_args @ rem | Variant_unboxed -> (arg, str, sort, layout) :: rem + | Variant_with_null -> + Misc.fatal_error "[Variant_with_null] not implemented yet" | Variant_extensible -> List.mapi (fun i { ca_sort } -> @@ -2379,6 +2381,7 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = in Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [ arg ], loc), lbl.lbl_sort, lbl_layout + | Record_inlined (_, _, Variant_with_null) -> assert false in let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in let str = add_barrier_to_let_kind ubr str in @@ -3197,8 +3200,9 @@ let split_cases tag_lambda_list = ((runtime_tag, act) :: consts, nonconsts) | Ordinary {runtime_tag}, Variant_boxed _ -> (consts, (runtime_tag, act) :: nonconsts) - | _, Variant_extensible -> assert false + | _, (Variant_extensible | Variant_with_null) -> assert false | Extension _, _ -> assert false + | Null, _ -> Misc.fatal_error "[Null] constructors not implemented" ) in let const, nonconst = split_rec tag_lambda_list in @@ -3222,7 +3226,7 @@ let split_extension_cases tag_lambda_list = match cstr_constant, cstr_tag with | true, Extension path -> Left (path, act) | false, Extension path -> Right (path, act) - | _, Ordinary _ -> assert false) + | _, (Ordinary _ | Null) -> assert false) tag_lambda_list let transl_match_on_option value_kind arg loc ~if_some ~if_none = diff --git a/lambda/translcore.ml b/lambda/translcore.ml index c27d89d16d4..5712986a93d 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -536,6 +536,9 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | [x] -> x | _ -> assert false end else begin match cstr.cstr_tag, cstr.cstr_repr with + | Null, _ -> Misc.fatal_error "[Null] constructors not implemented yet" + | Ordinary _, Variant_with_null -> + Misc.fatal_error "[Variant_with_null] not implemented yet" | Ordinary {runtime_tag}, _ when cstr.cstr_constant -> assert (args_with_sorts = []); (* CR layouts v5: This could have void args, but for now we've ruled @@ -609,7 +612,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = Pmakemixedblock(0, Immutable, shape, alloc_mode) in Lprim (makeblock, lam :: ll, of_location ~scopes e.exp_loc) - | Extension _, (Variant_boxed _ | Variant_unboxed) + | Extension _, (Variant_boxed _ | Variant_unboxed | Variant_with_null) | Ordinary _, Variant_extensible -> assert false end | Texp_extension_constructor (_, path) -> @@ -697,6 +700,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = in Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [targ], of_location ~scopes e.exp_loc) + | Record_inlined (_, _, Variant_with_null) -> assert false end | Texp_unboxed_field(arg, arg_sort, _id, lbl, _) -> begin match lbl.lbl_repres with @@ -752,7 +756,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = { value_prefix_len; flat_suffix } in Psetmixedfield(lbl.lbl_pos, write, shape, mode) - end + end + | Record_inlined (_, _, Variant_with_null) -> assert false in Lprim(access, [transl_exp ~scopes Jkind.Sort.Const.for_record arg; transl_exp ~scopes lbl.lbl_sort newval], @@ -1921,6 +1926,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = Psetmixedfield (lbl.lbl_pos, write, shape, Assignment modify_heap) end + | Record_inlined (_, _, Variant_with_null) -> assert false in Lsequence(Lprim(upd, [Lvar copy_id; transl_exp ~scopes lbl.lbl_sort expr], @@ -1994,6 +2000,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = { value_prefix_len; flat_suffix } in Pmixedfield (i, read, shape, sem) + | Record_inlined (_, _, Variant_with_null) -> assert false in Lprim(access, [Lvar init_id], of_location ~scopes loc), @@ -2036,8 +2043,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = blocks containing unboxed float literals. *) raise Not_constant - | Record_inlined (_, _, Variant_extensible) - | Record_inlined (Extension _, _, _) -> + | Record_inlined (_, _, (Variant_extensible | Variant_with_null)) + | Record_inlined ((Extension _ | Null), _, _) -> raise Not_constant with Not_constant -> let loc = of_location ~scopes loc in @@ -2081,6 +2088,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = let shape = transl_mixed_product_shape shape in Lprim (Pmakemixedblock (runtime_tag, mut, shape, Option.get mode), ll, loc) + | Record_inlined (_, _, Variant_with_null) -> assert false + | Record_inlined (Null, _, _) -> assert false in begin match opt_init_expr with None -> lam diff --git a/lambda/value_rec_compiler.ml b/lambda/value_rec_compiler.ml index 51568107cf6..be935829918 100644 --- a/lambda/value_rec_compiler.ml +++ b/lambda/value_rec_compiler.ml @@ -237,7 +237,8 @@ let compute_static_size lam = (Variant_boxed _ | Variant_extensible)) | Record_mixed shape -> Block (Mixed_record (size, Lambda.transl_mixed_product_shape shape)) - | Record_unboxed | Record_ufloat | Record_inlined (_, _, Variant_unboxed) -> + | Record_unboxed | Record_ufloat + | Record_inlined (_, _, (Variant_unboxed | Variant_with_null)) -> Misc.fatal_error "size_of_primitive" end | Pmakeblock _ -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index c91ccd3663b..a7a1494fa94 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -1469,8 +1469,12 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) (* CR layouts v5.9: support this *) Misc.fatal_error "Mixed blocks extensible variants are not supported") | Record_inlined (Extension _, _, _) - | Record_inlined (Ordinary _, _, (Variant_unboxed | Variant_extensible)) - | Record_unboxed -> + | Record_inlined + ( Ordinary _, + _, + (Variant_unboxed | Variant_extensible | Variant_with_null) ) + | Record_unboxed + | Record_inlined (Null, _, _) -> Misc.fatal_errorf "Cannot handle record kind for Pduprecord: %a" Printlambda.primitive prim in diff --git a/testsuite/tests/typing-layouts-or-null/reexport.ml b/testsuite/tests/typing-layouts-or-null/reexport.ml index 96bd392eed7..46ceeebc37f 100644 --- a/testsuite/tests/typing-layouts-or-null/reexport.ml +++ b/testsuite/tests/typing-layouts-or-null/reexport.ml @@ -335,3 +335,17 @@ let[@or_null_reexport] foo = 5 [%%expect{| val foo : int = 5 |}] + +(* [private] re-export fails. *) + +module Or_null = struct + type ('a : value) t : value_or_null = private 'a or_null [@@or_null_reexport] +end + +[%%expect{| +Line 2, characters 2-79: +2 | type ('a : value) t : value_or_null = private 'a or_null [@@or_null_reexport] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Invalid reexport declaration. + Type t must be defined equal to the primitive type or_null. +|}] diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index ae5e9146084..d0227ef029b 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -448,6 +448,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct match rep with | Variant_unboxed -> true | Variant_boxed _ | Variant_extensible -> false + | Variant_with_null -> + (* CR layouts v3.0: fix this. *) + Misc.fatal_error "[Variant_with_null] not implemented\ + in bytecode" in begin match cd_args with diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 4a305f36bf6..5f7b48b98b0 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -482,7 +482,7 @@ let is_exception_constructor env type_expr = let is_extension_constructor = function | Extension _ -> true - | Ordinary _ -> false + | Ordinary _ | Null -> false let () = (* This show_prim function will only show constructor types diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 4d4ccb6ad01..c83d8aea3d9 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -129,6 +129,12 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep = end | Variant_unboxed, ([] | _ :: _) -> Misc.fatal_error "Multiple or 0 constructors in [@@unboxed] variant" + | Variant_with_null, _ -> + (* CR layouts v3.5: this hardcodes ['a or_null]. Fix when we allow + users to write their own null constructors. *) + (* CR layouts v3.3: generalize to [any]. *) + [| Constructor_uniform_value, [| |] + ; Constructor_uniform_value, [| Jkind.Sort.Const.value |] |] in let all_void sorts = Array.for_all Jkind.Sort.Const.(equal void) sorts in let num_consts = ref 0 and num_nonconsts = ref 0 in @@ -155,7 +161,11 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep = then const_tag, 1 + const_tag, nonconst_tag else nonconst_tag, const_tag, 1 + nonconst_tag in - let cstr_tag = Ordinary {src_index; runtime_tag} in + let cstr_tag = + match rep, cstr_constant with + | Variant_with_null, true -> Null + | _, _ -> Ordinary {src_index; runtime_tag} + in let cstr_existentials, cstr_args, cstr_inlined = (* This is the representation of the inner record, IF there is one *) let record_repr = Record_inlined (cstr_tag, cstr_shape, rep) in @@ -273,7 +283,7 @@ let find_constr ~constant tag cstrs = (function | ({cstr_tag=Ordinary {runtime_tag=tag'}; cstr_constant},_) -> tag' = tag && cstr_constant = constant - | ({cstr_tag=Extension _},_) -> false) + | ({cstr_tag=(Extension _ | Null)},_) -> false) cstrs with | Not_found -> raise Constr_not_found diff --git a/typing/includecore.ml b/typing/includecore.ml index ba2b434ebae..9800ec9d09b 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -306,6 +306,7 @@ type type_mismatch = | Variant_mismatch of variant_change list | Unboxed_representation of position * attributes | Extensible_representation of position + | With_null_representation of position | Jkind of Jkind.Violation.t let report_modality_sub_error first second ppf e = @@ -634,6 +635,10 @@ let report_type_mismatch first second decl env ppf err = pr "Their internal representations differ:@ %s %s %s." (choose ord first second) decl "is extensible" + | With_null_representation ord -> + pr "Their internal representations differ:@ %s %s %s." + (choose ord first second) decl + "has a null constructor" | Jkind v -> Jkind.Violation.report_with_name ~name:first ppf v @@ -989,7 +994,8 @@ module Variant_diffing = struct match err, rep1, rep2 with | None, Variant_unboxed, Variant_unboxed | None, Variant_boxed _, Variant_boxed _ - | None, Variant_extensible, Variant_extensible -> None + | None, Variant_extensible, Variant_extensible + | None, Variant_with_null, Variant_with_null -> None | Some err, _, _ -> Some (Variant_mismatch err) | None, Variant_unboxed, Variant_boxed _ -> @@ -1000,6 +1006,10 @@ module Variant_diffing = struct Some (Extensible_representation First) | None, _, Variant_extensible -> Some (Extensible_representation Second) + | None, Variant_with_null, _ -> + Some (With_null_representation First) + | None, _, Variant_with_null -> + Some (With_null_representation Second) end (* Inclusion between "private" annotations *) diff --git a/typing/includecore.mli b/typing/includecore.mli index dea4a38b4cd..505d5e7cf57 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -119,6 +119,7 @@ type type_mismatch = | Variant_mismatch of variant_change list | Unboxed_representation of position * attributes | Extensible_representation of position + | With_null_representation of position | Jkind of Jkind.Violation.t type mmodes = diff --git a/typing/oprint.ml b/typing/oprint.ml index 914bff8f8e7..a714d1aec3f 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -976,6 +976,11 @@ and print_out_type_decl kwd ppf td = let print_unboxed ppf = if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else () in + let print_or_null_reexport ppf = + if td.otype_or_null_reexport then + fprintf ppf " [%@%@or_null_reexport]" + else () + in let print_out_tkind ppf = function | Otyp_abstract -> () | Otyp_record lbls -> @@ -1001,12 +1006,13 @@ and print_out_type_decl kwd ppf td = print_private td.otype_private !out_type ty in - fprintf ppf "@[<2>@[%t%a%a@]%t%t@]" + fprintf ppf "@[<2>@[%t%a%a@]%t%t%t@]" print_name_params print_out_jkind_annot td.otype_jkind print_out_tkind ty print_constraints print_unboxed + print_or_null_reexport and print_simple_out_gf_type ppf (ty, gf) = let m_legacy, m_new = partition_modalities gf in diff --git a/typing/outcometree.mli b/typing/outcometree.mli index b0df11dc455..8defebafc99 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -204,6 +204,7 @@ and out_type_decl = otype_jkind: out_jkind option; otype_unboxed: bool; + otype_or_null_reexport: bool; otype_cstrs: (out_type * out_type) list } and out_extension_constructor = { oext_name: string; diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 593a4d7ca21..277c56addc1 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -923,7 +923,7 @@ let should_extend ext env = match ext with | (p,_)::_ -> let open Patterns.Head in begin match p.pat_desc with - | Construct {cstr_tag=Ordinary _} -> + | Construct {cstr_tag=Ordinary _ | Null} -> let path = get_constructor_type_path p.pat_type p.pat_env in Path.same path ext | Construct {cstr_tag=Extension _} -> false @@ -2129,7 +2129,7 @@ let extendable_path path = Path.same path Predef.path_option) let rec collect_paths_from_pat r p = match p.pat_desc with -| Tpat_construct(_, {cstr_tag=Ordinary _}, ps, _) -> +| Tpat_construct(_, {cstr_tag=Ordinary _ | Null}, ps, _) -> let path = get_constructor_type_path p.pat_type p.pat_env in List.fold_left collect_paths_from_pat diff --git a/typing/predef.ml b/typing/predef.ml index 9b201afbede..6e140f2ffb1 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -477,6 +477,8 @@ let add_small_number_beta_extension_types add_type env = |> add_type ident_int16 ~jkind:Jkind.Const.Builtin.immediate let or_null_kind tvar = + (* CR layouts v3: use [Variant_with_null] when it's supported + in the backend. *) variant [cstr ident_null []; cstr ident_this [unrestricted tvar or_null_argument_sort]] diff --git a/typing/printtyp.ml b/typing/printtyp.ml index f75357288ad..e91897f5d75 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1934,35 +1934,46 @@ let tree_of_type_decl id decl = in let (name, args) = type_defined decl in let constraints = tree_of_constraints params in - let ty, priv, unboxed = + let ty, priv, unboxed, or_null_reexport = match decl.type_kind with | Type_abstract _ -> begin match ty_manifest with - | None -> (Otyp_abstract, Public, false) + | None -> (Otyp_abstract, Public, false, false) | Some ty -> - tree_of_typexp Type ty, decl.type_private, false + tree_of_typexp Type ty, decl.type_private, false, false end | Type_variant (cstrs, rep) -> let unboxed = match rep with | Variant_unboxed -> true - | Variant_boxed _ | Variant_extensible -> false + | Variant_boxed _ | Variant_extensible | Variant_with_null -> false + in + (* CR layouts v3.5: remove when [Variant_with_null] is merged into + [Variant_unboxed]. *) + let or_null_reexport = + match rep with + | Variant_with_null -> true + | Variant_boxed _ | Variant_unboxed | Variant_extensible -> false in tree_of_manifest (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), decl.type_private, - unboxed + unboxed, + or_null_reexport | Type_record(lbls, rep) -> tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), decl.type_private, - (match rep with Record_unboxed -> true | _ -> false) + (match rep with Record_unboxed -> true | _ -> false), + false | Type_record_unboxed_product(lbls, Record_unboxed_product) -> tree_of_manifest (Otyp_record_unboxed_product (List.map tree_of_label lbls)), decl.type_private, + false, false | Type_open -> tree_of_manifest Otyp_open, decl.type_private, + false, false in (* The algorithm for setting [lay] here is described as Case (C1) in @@ -1984,6 +1995,7 @@ let tree_of_type_decl id decl = otype_private = priv; otype_jkind; otype_unboxed = unboxed; + otype_or_null_reexport = or_null_reexport; otype_cstrs = constraints } let add_type_decl_to_preparation id decl = diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 153dd95a48f..5dc8b08d96e 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -188,6 +188,7 @@ let tag ppf = let open Types in function | Ordinary {src_index;runtime_tag} -> fprintf ppf "Ordinary {index: %d; tag: %d}" src_index runtime_tag | Extension p -> fprintf ppf "Extension %a" fmt_path p + | Null -> fprintf ppf "Null" let variant_representation i ppf = let open Types in function | Variant_unboxed -> @@ -198,6 +199,7 @@ let variant_representation i ppf = let open Types in function sort_array (i+1) ppf sorts)) cstrs | Variant_extensible -> line i ppf "Variant_inlined\n" + | Variant_with_null -> line i ppf "Variant_with_null\n" let flat_element i ppf flat_element = line i ppf "%s\n" (Types.flat_element_to_string flat_element) diff --git a/typing/typecore.ml b/typing/typecore.ml index ac078c4bbfa..a028ef1bbcf 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -5417,7 +5417,9 @@ and type_expect_ (rep : rep) = match record_form with | Legacy -> begin match rep with - | Record_unboxed | Record_inlined (_, _, Variant_unboxed) -> false + | Record_unboxed + | Record_inlined (_, _, (Variant_unboxed | Variant_with_null)) + -> false | Record_boxed _ | Record_float | Record_ufloat | Record_mixed _ | Record_inlined (_, _, (Variant_boxed _ | Variant_extensible)) -> true @@ -8416,7 +8418,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg in let (argument_mode, alloc_mode) = match constr.cstr_repr with - | Variant_unboxed -> expected_mode, None + | Variant_unboxed | Variant_with_null -> expected_mode, None | Variant_boxed _ when constr.cstr_constant -> expected_mode, None | Variant_boxed _ | Variant_extensible -> let alloc_mode, argument_mode = register_allocation expected_mode in @@ -8453,6 +8455,8 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg raise(Error(loc, env, Private_constructor (constr, ty_res))) | Variant_boxed _ | Variant_unboxed -> raise (Error(loc, env, Private_type ty_res)); + | Variant_with_null -> assert false + (* [Variant_with_null] can't be made private due to [or_null_reexport]. *) end; (* NOTE: shouldn't we call "re" on this final expression? -- AF *) { texp with diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 72b12a3d787..30f24d1577f 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1664,6 +1664,11 @@ let update_decl_jkind env dpath decl = let update_variant_kind cstrs rep = (* CR layouts: factor out duplication *) match cstrs, rep with + | _, Variant_with_null -> + (* CR layouts v3.5: this case only happens with [or_null_reexport]. + Change when we allow users to write their own null constructors. *) + (* CR layouts v3.3: use [any_non_null]. *) + cstrs, rep, Jkind.Builtin.value_or_null ~why:(Primitive Predef.ident_or_null) | [{Types.cd_args} as cstr], Variant_unboxed -> begin match cd_args with | Cstr_tuple [{ca_type=ty; _} as arg] -> begin @@ -1738,8 +1743,7 @@ let update_decl_jkind env dpath decl = type_jkind; type_has_illegal_crossings }, type_jkind - (* CR layouts v3.0: handle this case in [update_variant_jkind] when - [Variant_with_null] introduced. + (* CR layouts v3.0: remove this once [or_null] is [Variant_with_null]. No updating required for [or_null_reexport], and we must not incorrectly override the jkind to [non_null]. diff --git a/typing/typedtree.ml b/typing/typedtree.ml index c78b97000c9..41e1c042633 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -1124,6 +1124,11 @@ let iter_pattern_full ~of_sort ~of_const_sort ~both_sides_of_or f sort pat = let sorts = match cstr.cstr_repr with | Variant_unboxed -> [ sort ] + (* CR layouts v3.5: this hardcodes ['a or_null]. Fix when we allow + users to write their own null constructors. *) + | Variant_with_null when cstr.cstr_constant -> [] + (* CR layouts v3.3: allow all sorts. *) + | Variant_with_null -> [ value ] | Variant_boxed _ | Variant_extensible -> (List.map (fun { ca_sort } -> of_const_sort ca_sort ) cstr.cstr_args) diff --git a/typing/typeopt.ml b/typing/typeopt.ml index a314ab84e5a..f76557ed36e 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -560,6 +560,15 @@ and value_kind_variant env ~loc ~visited ~depth ~num_nodes_visited (cstrs : Types.constructor_declaration list) rep = match rep with | Variant_extensible -> assert false + | Variant_with_null -> begin + match cstrs with + | [_; {cd_args=Cstr_tuple [{ca_type=ty}]}] -> + let num_nodes_visited, kind = + value_kind env ~loc ~visited ~depth ~num_nodes_visited ty + in + num_nodes_visited + 1, { kind with nullable = Nullable } + | _ -> assert false + end | Variant_unboxed -> begin (* CR layouts v1.5: This should only be reachable in the case of a missing cmi, according to the comment on scrape_ty. Reevaluate whether it's @@ -701,6 +710,7 @@ and value_kind_record env ~loc ~visited ~depth ~num_nodes_visited value_kind env ~loc ~visited ~depth ~num_nodes_visited ld_type | [] | _ :: _ :: _ -> assert false end + | Record_inlined (_, _, Variant_with_null) -> assert false | Record_inlined (_, _, (Variant_boxed _ | Variant_extensible)) | Record_boxed _ | Record_float | Record_ufloat | Record_mixed _ -> begin let is_mutable = @@ -780,6 +790,7 @@ and value_kind_record env ~loc ~visited ~depth ~num_nodes_visited | Record_mixed _ -> [0, fields] | Record_unboxed -> assert false + | Record_inlined (Null, _, _) -> assert false in (num_nodes_visited, mk_nn (Pvariant { consts = []; non_consts })) end diff --git a/typing/types.ml b/typing/types.ml index a745ae47150..b9f363f2cc0 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -286,6 +286,7 @@ and ('lbl, 'lbl_flat, 'cstr) type_kind = and tag = Ordinary of {src_index: int; (* Unique name (per type) *) runtime_tag: int} (* The runtime tag *) | Extension of Path.t + | Null and type_origin = Definition @@ -324,6 +325,7 @@ and variant_representation = | Variant_boxed of (constructor_representation * Jkind_types.Sort.Const.t array) array | Variant_extensible + | Variant_with_null and constructor_representation = | Constructor_uniform_value @@ -606,15 +608,19 @@ let equal_tag t1 t2 = | Ordinary {src_index=i1}, Ordinary {src_index=i2} -> i2 = i1 (* If i1 = i2, the runtime_tags will also be equal *) | Extension path1, Extension path2 -> Path.same path1 path2 - | (Ordinary _ | Extension _), _ -> false + | Null, Null -> true + | (Ordinary _ | Extension _ | Null), _ -> false let compare_tag t1 t2 = match (t1, t2) with | Ordinary {src_index=i1}, Ordinary {src_index=i2} -> Int.compare i1 i2 | Extension path1, Extension path2 -> Path.compare path1 path2 - | Ordinary _, Extension _ -> -1 - | Extension _, Ordinary _ -> 1 + | Null, Null -> 0 + | Ordinary _, (Extension _ | Null) -> -1 + | (Extension _ | Null), Ordinary _ -> 1 + | Extension _, Null -> -1 + | Null, Extension _ -> 1 let equal_flat_element e1 e2 = match e1, e2 with @@ -669,7 +675,8 @@ let equal_variant_representation r1 r2 = r1 == r2 || match r1, r2 with cstrs_and_sorts2 | Variant_extensible, Variant_extensible -> true - | (Variant_unboxed | Variant_boxed _ | Variant_extensible), _ -> + | Variant_with_null, Variant_with_null -> true + | (Variant_unboxed | Variant_boxed _ | Variant_extensible | Variant_with_null), _ -> false let equal_record_representation r1 r2 = match r1, r2 with @@ -745,15 +752,14 @@ let find_unboxed_type decl = | Type_record_unboxed_product ([{ld_type = arg; _}], Record_unboxed_product) | Type_variant ([{cd_args = Cstr_tuple [{ca_type = arg; _}]; _}], Variant_unboxed) - | Type_variant ([{cd_args = Cstr_record [{ld_type = arg; _}]; _}], - Variant_unboxed) -> + | Type_variant ([{cd_args = Cstr_record [{ld_type = arg; _}]; _}], Variant_unboxed) -> Some arg | Type_record (_, ( Record_inlined _ | Record_unboxed | Record_boxed _ | Record_float | Record_ufloat | Record_mixed _)) | Type_record_unboxed_product (_, Record_unboxed_product) | Type_variant (_, ( Variant_boxed _ | Variant_unboxed - | Variant_extensible )) + | Variant_extensible | Variant_with_null)) | Type_abstract _ | Type_open -> None diff --git a/typing/types.mli b/typing/types.mli index c8613d7e262..f74484bdf87 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -570,6 +570,7 @@ and ('lbl, 'lbl_flat, 'cstr) type_kind = and tag = Ordinary of {src_index: int; (* Unique name (per type) *) runtime_tag: int} (* The runtime tag *) | Extension of Path.t + | Null (* Null pointer *) (* A mixed product contains a possibly-empty prefix of values followed by a non-empty suffix of "flat" elements. Intuitively, a flat element is one that @@ -634,6 +635,11 @@ and variant_representation = [Constructor_mixed] if the inlined record has any unboxed fields. *) | Variant_extensible + | Variant_with_null + (* CR layouts v3.5: A custom variant representation for ['a or_null]. + Eventually, it should likely be merged into [Variant_unboxed], with + [Variant_unboxed] allowing either one ordinary constructor, or one + ordinary non-null and one [Null] constructor. *) and constructor_representation = | Constructor_uniform_value diff --git a/typing/value_rec_check.ml b/typing/value_rec_check.ml index 6b76def1e0a..bb09b38b606 100644 --- a/typing/value_rec_check.ml +++ b/typing/value_rec_check.ml @@ -735,7 +735,7 @@ let rec expression : Typedtree.expression -> term_judg = | _ -> empty in let arg_mode i = match desc.cstr_repr with - | Variant_unboxed -> + | Variant_unboxed | Variant_with_null -> Return | Variant_boxed _ | Variant_extensible -> (match desc.cstr_shape with From fe97bebd12bc35d416ac1bed16ff6e1e60220055 Mon Sep 17 00:00:00 2001 From: Aspen Smith Date: Sat, 28 Dec 2024 11:47:55 -0500 Subject: [PATCH 08/30] Add attributes to (unsafely) skip jkind check (#3385) * Add attributes to (unsafely) skip jkind check Add a pair of attributes, [@@unsafe_allow_any_kind_in_intf] and [@@unsafe_allow_any_kind_in_impl], which if set on both the impl and the intf respectively, skip checking the jkind of the type in a signature against the jkind of the type in a struct entirely. This is a more-selective version of the `--allow-illegal-crossing` flag, and likely eventually subsumes it. Signed-off-by: Aspen Smith * Emit a warning when unsafe_allow_any_kind is added unnecessarily Note that this is /only/ done if the attribute is set in both signatures but not used - also this is a little over-sensitive (sadly) since this is done during sigature inclusion too. A new test covers the over-sensitivity. Signed-off-by: Aspen Smith --------- Signed-off-by: Aspen Smith --- parsing/builtin_attributes.ml | 19 +- parsing/builtin_attributes.mli | 5 + testsuite/tests/typing-layouts/allow_any.ml | 190 ++++++++++++++++++++ typing/includecore.ml | 28 ++- utils/warnings.ml | 11 ++ utils/warnings.mli | 1 + 6 files changed, 243 insertions(+), 11 deletions(-) create mode 100644 testsuite/tests/typing-layouts/allow_any.ml diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index f5a1fb02ffb..042062ebd61 100644 --- a/parsing/builtin_attributes.ml +++ b/parsing/builtin_attributes.ml @@ -504,6 +504,10 @@ let has_unboxed attrs = has_attribute "unboxed" attrs let has_boxed attrs = has_attribute "boxed" attrs +let has_unsafe_allow_any_kind_in_intf attrs = has_attribute "unsafe_allow_any_kind_in_intf" attrs + +let has_unsafe_allow_any_kind_in_impl attrs = has_attribute "unsafe_allow_any_kind_in_impl" attrs + let parse_empty_payload attr = match attr.attr_payload with | PStr [] -> Some () @@ -602,6 +606,15 @@ let zero_alloc_attribute (attr : Parsetree.attribute) = warn_payload attr.attr_loc attr.attr_name.txt "Only 'all', 'check', 'check_opt', 'check_all', and 'check_none' are supported") +let attribute_with_ignored_payload name attr = + when_attribute_is [name; "ocaml." ^ name] attr ~f:(fun () -> ()) + +let unsafe_allow_any_kind_in_impl_attribute = + attribute_with_ignored_payload "unsafe_allow_any_kind_in_impl" + +let unsafe_allow_any_kind_in_intf_attribute = + attribute_with_ignored_payload "unsafe_allow_any_kind_in_intf" + let afl_inst_ratio_attribute attr = clflags_attribute_with_int_payload attr ~name:"afl_inst_ratio" Clflags.afl_inst_ratio @@ -610,7 +623,8 @@ let parse_standard_interface_attributes attr = warning_attribute attr; principal_attribute attr; noprincipal_attribute attr; - nolabels_attribute attr + nolabels_attribute attr; + unsafe_allow_any_kind_in_intf_attribute attr let parse_standard_implementation_attributes attr = warning_attribute attr; @@ -621,7 +635,8 @@ let parse_standard_implementation_attributes attr = afl_inst_ratio_attribute attr; flambda_o3_attribute attr; flambda_oclassic_attribute attr; - zero_alloc_attribute attr + zero_alloc_attribute attr; + unsafe_allow_any_kind_in_impl_attribute attr let has_no_mutable_implied_modalities attrs = has_attribute "no_mutable_implied_modalities" attrs diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli index 189b6eeded6..d1f95feac31 100644 --- a/parsing/builtin_attributes.mli +++ b/parsing/builtin_attributes.mli @@ -35,6 +35,8 @@ - ocaml.tailcall - ocaml.tail_mod_cons - ocaml.unboxed + - ocaml.unsafe_allow_any_kind_in_impl + - ocaml.unsafe_allow_any_kind_in_intf - ocaml.untagged - ocaml.unrolled - ocaml.warnerror @@ -198,6 +200,9 @@ val explicit_arity: Parsetree.attributes -> bool val has_unboxed: Parsetree.attributes -> bool val has_boxed: Parsetree.attributes -> bool +val has_unsafe_allow_any_kind_in_impl: Parsetree.attributes -> bool +val has_unsafe_allow_any_kind_in_intf: Parsetree.attributes -> bool + val parse_standard_interface_attributes : Parsetree.attribute -> unit val parse_standard_implementation_attributes : Parsetree.attribute -> unit diff --git a/testsuite/tests/typing-layouts/allow_any.ml b/testsuite/tests/typing-layouts/allow_any.ml new file mode 100644 index 00000000000..3e8eb85199b --- /dev/null +++ b/testsuite/tests/typing-layouts/allow_any.ml @@ -0,0 +1,190 @@ +(* TEST + flags = "-extension layouts_beta"; + expect; +*) + +(* Baseline: if the jkind doesn't match, we should get an error. *) +module Mismatched_no_attrs : sig + type t : float64 +end = struct + type t = string +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = string +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = string end + is not included in + sig type t : float64 end + Type declarations do not match: + type t = string + is not included in + type t : float64 + The layout of the first is value + because it is the primitive type string. + But the layout of the first must be a sublayout of float64 + because of the definition of t at line 2, characters 2-18. +|}] + +(* On the other hand, if we set the correct attributes on both the impl and the intf, we + shouldn't get an error (though, obviously, this is completely unsound!) *) +module Mismatched_with_both_attrs : sig + type t : float64 + [@@unsafe_allow_any_kind_in_impl "I love segfaults"] +end = struct + type t = string + [@@unsafe_allow_any_kind_in_intf "I love segfaults"] +end +[%%expect{| +module Mismatched_with_both_attrs : sig type t : float64 end +|}] + +(* If we set the attributes but *don't* get a kind mismatch, we ought to be fine *) +module Matching : sig + type t : value + [@@unsafe_allow_any_kind_in_impl "I love segfaults"] +end = struct + type t = string + [@@unsafe_allow_any_kind_in_intf "I love segfaults"] +end +[%%expect{| +Lines 2-3, characters 2-54: +2 | ..type t : value +3 | [@@unsafe_allow_any_kind_in_impl "I love segfaults"] +Warning 212 [unnecessary-allow-any-kind]: [@@allow_any_kind_in_intf] and [@@allow_any_kind_in_impl] set on a +type, but the kind matches. The attributes can be removed. + +module Matching : sig type t end +|}] + +(* If the attr is only on the signature we should get an error *) +module Mismatched_with_attr_on_intf : sig + type t : float64 + [@@unsafe_allow_any_kind_in_impl "I love segfaults"] +end = struct + type t = string +end +[%%expect{| +Lines 4-6, characters 6-3: +4 | ......struct +5 | type t = string +6 | end +Error: Signature mismatch: + Modules do not match: + sig type t = string end + is not included in + sig type t : float64 end + Type declarations do not match: + type t = string + is not included in + type t : float64 + The layout of the first is value + because it is the primitive type string. + But the layout of the first must be a sublayout of float64 + because of the definition of t at lines 2-3, characters 2-54. +|}] + +(* If the attr is only on the struct we should get an error *) +module Mismatched_with_attr_on_impl : sig + type t : float64 +end = struct + type t = string + [@@unsafe_allow_any_kind_in_intf "I love segfaults"] +end +[%%expect{| +Lines 3-6, characters 6-3: +3 | ......struct +4 | type t = string +5 | [@@unsafe_allow_any_kind_in_intf "I love segfaults"] +6 | end +Error: Signature mismatch: + Modules do not match: + sig type t = string end + is not included in + sig type t : float64 end + Type declarations do not match: + type t = string + is not included in + type t : float64 + The layout of the first is value + because it is the primitive type string. + But the layout of the first must be a sublayout of float64 + because of the definition of t at line 2, characters 2-18. +|}] + +(* Some more complex stuff with functors *) + +module type S1 = sig + type t : value +end + +module type S2 = sig + type t : float64 + [@@unsafe_allow_any_kind_in_impl] +end + +module type S1 = sig + type t : value + [@@unsafe_allow_any_kind_in_intf] +end + +module F1 (X : S1) : S2 = X + +[%%expect{| +module type S1 = sig type t end +module type S2 = sig type t : float64 end +module type S1 = sig type t end +module F1 : functor (X : S1) -> S2 +|}] + +module F2 (X : S2) : S1 = X +[%%expect{| +Line 1, characters 26-27: +1 | module F2 (X : S2) : S1 = X + ^ +Error: Signature mismatch: + Modules do not match: sig type t = X.t end is not included in S1 + Type declarations do not match: type t = X.t is not included in type t + The layout of the first is float64 + because of the definition of t at lines 6-7, characters 2-35. + But the layout of the first must be a sublayout of value + because of the definition of t at lines 11-12, characters 2-35. +|}] + +(* Non-abstract types can be annotated with [@@unsafe_allow_any_kind_in_intf] too, and get + checked against signatures during inclusion. *) + +module M1 : sig + type t : value = string [@@unsafe_allow_any_kind_in_intf] +end = struct + type t = string +end + +module M2 : S2 = M1 + +[%%expect{| +module M1 : sig type t = string end +module M2 : S2 +|}] + +module type S3 = sig + type t : value + [@@unsafe_allow_any_kind_in_impl] +end + +module M3 : S3 = M1 +(* CR aspsmith: This is somewhat unfortunate, if S3 and M1 are defined far away, but it's + unclear how to squash the warning *) +[%%expect{| +module type S3 = sig type t end +Lines 2-3, characters 2-35: +2 | ..type t : value +3 | [@@unsafe_allow_any_kind_in_impl] +Warning 212 [unnecessary-allow-any-kind]: [@@allow_any_kind_in_intf] and [@@allow_any_kind_in_impl] set on a +type, but the kind matches. The attributes can be removed. + +module M3 : S3 +|}] diff --git a/typing/includecore.ml b/typing/includecore.ml index 9800ec9d09b..a6a6a9576c4 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -1348,15 +1348,25 @@ let type_declarations ?(equality = false) ~loc env ~mark name rep1 rep2 in let err = match (decl1.type_kind, decl2.type_kind) with - (_, Type_abstract _) -> - (* Note that [decl2.type_jkind] is an upper bound. - If it isn't tight, [decl2] must - have a manifest, which we're already checking for equality - above. Similarly, [decl1]'s kind may conservatively approximate its - jkind, but [check_decl_jkind] will expand its manifest. *) - (match Ctype.check_decl_jkind env decl1 decl2.type_jkind with - | Ok _ -> None - | Error v -> Some (Jkind v)) + (_, Type_abstract _) -> begin + (* If both the intf has "allow any kind in impl" *and* the impl has "allow any + kind in intf", don't check the jkind at all. *) + let allow_any = + Builtin_attributes.has_unsafe_allow_any_kind_in_impl decl2.type_attributes + && Builtin_attributes.has_unsafe_allow_any_kind_in_intf decl1.type_attributes + in + (* Note that [decl2.type_jkind] is an upper bound. If it isn't tight, [decl2] must + have a manifest, which we're already checking for equality above. Similarly, + [decl1]'s kind may conservatively approximate its jkind, but [check_decl_jkind] + will expand its manifest. *) + match Ctype.check_decl_jkind env decl1 decl2.type_jkind with + | Ok _ -> + (if allow_any + then Location.prerr_warning decl2.type_loc (Warnings.Unnecessary_allow_any_kind)); + None + | Error _ when allow_any -> None + | Error v -> Some (Jkind v) + end | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) -> if mark then begin let mark usage cstrs = diff --git a/utils/warnings.ml b/utils/warnings.ml index a5580a86ed7..cd13e4cd3ee 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -129,6 +129,7 @@ type t = | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Mod_by_top of string (* 211 *) + | Unnecessary_allow_any_kind (* 212 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -217,6 +218,7 @@ let number = function | Unchecked_zero_alloc_attribute -> 199 | Unboxing_impossible -> 210 | Mod_by_top _ -> 211 + | Unnecessary_allow_any_kind -> 212 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where @@ -592,6 +594,11 @@ let descriptions = [ names = ["mod-by-top"]; description = "Including the top-most element of an axis in a kind's modifiers is a no-op."; since = since 4 14 }; + { number = 212; + names = ["unnecessary-allow-any-kind"]; + description = "[@@unsafe_allow_any_kind_in_{impl,intf}] attributes included \ + on a type and a signature with matching kinds"; + since = since 5 1 }; ] let name_to_number = @@ -1235,6 +1242,10 @@ let message = function "%s is the top-most modifier.\n\ Modifying by a top element is a no-op." modifier + | Unnecessary_allow_any_kind -> + Printf.sprintf + "[@@allow_any_kind_in_intf] and [@@allow_any_kind_in_impl] set on a \n\ + type, but the kind matches. The attributes can be removed." ;; let nerrors = ref 0 diff --git a/utils/warnings.mli b/utils/warnings.mli index d925ffce77d..e7c7da9d588 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -135,6 +135,7 @@ type t = | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Mod_by_top of string (* 211 *) + | Unnecessary_allow_any_kind (* 212 *) type alert = {kind:string; message:string; def:loc; use:loc} From 8b99545232890e7991f4456954201cd22d728f04 Mon Sep 17 00:00:00 2001 From: Thomas Del Vecchio <127883551+tdelvecchio-jsc@users.noreply.github.com> Date: Mon, 30 Dec 2024 14:26:48 -0500 Subject: [PATCH 09/30] Fix case where parser drops attributes in packed module types. (#3262) * Demonstrate dropped attributes in test. Signed-off-by: Thomas Del Vecchio * Syntax error on misplaced attribute in packed module types. Signed-off-by: Thomas Del Vecchio --------- Signed-off-by: Thomas Del Vecchio --- parsing/parse.ml | 2 ++ parsing/parser.mly | 7 ++++++- parsing/syntaxerr.ml | 1 + parsing/syntaxerr.mli | 1 + ..._attribute_ptyp_package.compilers.reference | 10 ++++++++++ .../parsing/dropped_attribute_ptyp_package.ml | 18 ++++++++++++++++++ 6 files changed, 38 insertions(+), 1 deletion(-) create mode 100644 testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference create mode 100644 testsuite/tests/parsing/dropped_attribute_ptyp_package.ml diff --git a/parsing/parse.ml b/parsing/parse.ml index 1e2253b367a..1b3f6da349a 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -160,6 +160,8 @@ let prepare_error err = Format.fprintf ppf "only module type identifier and %a constraints are supported" Style.inline_code "with type" + | Misplaced_attribute -> + Format.fprintf ppf "an attribute cannot go here" in Location.errorf ~loc "invalid package type: %a" invalid ipt | Removed_string_set loc -> diff --git a/parsing/parser.mly b/parsing/parser.mly index 4c60074d276..3d2e13a7a8e 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -808,7 +808,12 @@ let package_type_of_module_type pmty = in match pmty with | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes) - | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> + | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid; pmty_attributes = inner_attributes}, cstrs)} -> + begin match inner_attributes with + | [] -> () + | attr :: _ -> + err attr.attr_loc Syntaxerr.Misplaced_attribute + end; (lid, List.map map_cstr cstrs, pmty.pmty_attributes) | _ -> err pmty.pmty_loc Neither_identifier_nor_with_type diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index 76eab18b8e8..c1dbac71d7b 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -21,6 +21,7 @@ type invalid_package_type = | Private_types | Not_with_type | Neither_identifier_nor_with_type + | Misplaced_attribute type error = Unclosed of Location.t * string * Location.t * string diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 54c619eb877..47f2910fd0e 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -26,6 +26,7 @@ type invalid_package_type = | Private_types | Not_with_type | Neither_identifier_nor_with_type + | Misplaced_attribute type error = Unclosed of Location.t * string * Location.t * string diff --git a/testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference b/testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference new file mode 100644 index 00000000000..3469a279e39 --- /dev/null +++ b/testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference @@ -0,0 +1,10 @@ +module type T = sig type t end +Line 3, characters 22-29: +3 | val foo : (module T [@attr] with type t = 'a) -> unit + ^^^^^^^ +Error: invalid package type: an attribute cannot go here +Line 3, characters 33-40: +3 | let foo (type a) (module M : T [@attr] with type t = a) = () + ^^^^^^^ +Error: invalid package type: an attribute cannot go here + diff --git a/testsuite/tests/parsing/dropped_attribute_ptyp_package.ml b/testsuite/tests/parsing/dropped_attribute_ptyp_package.ml new file mode 100644 index 00000000000..9fea993cc05 --- /dev/null +++ b/testsuite/tests/parsing/dropped_attribute_ptyp_package.ml @@ -0,0 +1,18 @@ +(* TEST + toplevel; +*) + +(* There is no place for the following attributes to attach to; the compiler should error + rather than silently dropping them (as it used to do). *) + +module type T = sig + type t +end;; + +module type U = sig + val foo : (module T [@attr] with type t = 'a) -> unit +end;; + +module U : U = struct + let foo (type a) (module M : T [@attr] with type t = a) = () +end;; From ab229fce09dd33c191962596285d2e7e889760b9 Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Tue, 31 Dec 2024 10:42:37 +0000 Subject: [PATCH 10/30] ASR 64-bit lane not available in sse instruction (#3413) --- backend/amd64/simd_selection.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/backend/amd64/simd_selection.ml b/backend/amd64/simd_selection.ml index 2955d27e6de..526d37d3f11 100644 --- a/backend/amd64/simd_selection.ml +++ b/backend/amd64/simd_selection.ml @@ -589,13 +589,14 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) let sse_op = match width_type with | W128 -> assert false - | W64 -> assert false - | W32 -> SRA_i32 - | W16 -> SRA_i16 - | W8 -> assert false + | W64 -> None + | W32 -> Some SRA_i32 + | W16 -> Some SRA_i16 + | W8 -> None in - Operation.Specific (Isimd (SSE2 sse_op)) - |> make_default ~arg_count ~res_count + Option.bind sse_op (fun sse_op -> + Operation.Specific (Isimd (SSE2 sse_op)) + |> make_default ~arg_count ~res_count) | Icomp (Isigned intcomp) -> ( match intcomp with | Ceq -> From e1a5fe42d53e2cdf1e27e333782dff8b311edf5f Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Tue, 31 Dec 2024 10:54:43 +0000 Subject: [PATCH 11/30] CI: simplify the regalloc jobs (#3389) --- .github/workflows/build.yml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index c9193354c58..7ba2cf29628 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -99,36 +99,36 @@ jobs: - name: irc config: --enable-middle-end=flambda2 os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' - ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' + build_ocamlparam: '_,w=-46,regalloc=irc' + ocamlparam: '_,w=-46,regalloc=irc' check_arch: true - name: irc_polling config: --enable-middle-end=flambda2 --enable-poll-insertion os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' - ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' + build_ocamlparam: '_,w=-46,regalloc=irc' + ocamlparam: '_,w=-46,regalloc=irc' check_arch: true - name: irc_frame_pointers config: --enable-middle-end=flambda2 --enable-frame-pointers os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' - ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' + build_ocamlparam: '_,w=-46,regalloc=irc' + ocamlparam: '_,w=-46,regalloc=irc' check_arch: true - name: ls config: --enable-middle-end=flambda2 os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1' - ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1' + build_ocamlparam: '_,w=-46,regalloc=ls' + ocamlparam: '_,w=-46,regalloc=ls' check_arch: true - name: gi config: --enable-middle-end=flambda2 os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1,vectorize=1' - ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1,vectorize=1' + build_ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1,vectorize=1' + ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1,vectorize=1' check_arch: true - name: cfg-selection From 9e7c322ec6683300e67b50aa466a9db520a8973f Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Tue, 31 Dec 2024 12:01:21 +0000 Subject: [PATCH 12/30] Separate test for vectorizer in the CI (#3414) * Separate test for vectorizer in the CI * Remove vectorizer from "gi" CI job --- .github/workflows/build.yml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 7ba2cf29628..bae0b5cdb81 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -127,8 +127,8 @@ jobs: - name: gi config: --enable-middle-end=flambda2 os: ubuntu-latest - build_ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1,vectorize=1' - ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1,vectorize=1' + build_ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1' + ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1' check_arch: true - name: cfg-selection @@ -138,6 +138,13 @@ jobs: ocamlparam: '_,w=-46,regalloc=cfg,cfg-cse-optimize=1,cfg-selection=1,cfg-zero-alloc-checker=1' check_arch: true + - name: vectorizer + config: --enable-middle-end=flambda2 + os: ubuntu-latest + build_ocamlparam: '_,w=-46,regalloc=cfg,vectorize=1' + ocamlparam: '_,w=-46,regalloc=cfg,vectorize=1' + check_arch: true + env: J: "3" run_testsuite: "true" From 55490150f17c17d981fb717820526a87d41f0bda Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Tue, 31 Dec 2024 17:20:56 +0000 Subject: [PATCH 13/30] Vectorizer: check register compatibility (#3412) Check that registers are compatible when joining computations --- backend/cfg/vectorize.ml | 34 ++++++++++++++++++++++++++++------ 1 file changed, 28 insertions(+), 6 deletions(-) diff --git a/backend/cfg/vectorize.ml b/backend/cfg/vectorize.ml index a225018a57f..77703302f84 100644 --- a/backend/cfg/vectorize.ml +++ b/backend/cfg/vectorize.ml @@ -2725,10 +2725,32 @@ end = struct t1.new_positions t2.new_positions } + (** address registers and vectorizable registers of [t] and [t'] are compatible, i.e., + register [r] used as an address argument in [t] is not replaced by a vectorizable + argument in [t'] and vice versa. *) + let register_compatible t t' deps = + let sub t1 t2 = + Instruction.Id.Map.for_all + (fun _key g1 -> + let scalar_instructions = Group.scalar_instructions g1 in + Group.for_all_non_vectorizable_args g1 ~f:(fun ~arg_i -> + List.for_all + (fun i -> + match + Dependencies.get_direct_dependency_of_arg deps + (Instruction.id i) ~arg_i + with + | None -> true + | Some dep -> not (contains_id t2 dep)) + scalar_instructions)) + t1.groups + in + sub t t' && sub t' t + (** [compatible t t'] returns true if for every group [g] in [t], and [g'] in [t'], [g] and [g'] are equal or have disjoint sets of scalar instructions. *) - let compatible t t' = + let instruction_compatible t t' = if Instruction.Id.Set.disjoint t.all_scalar_instructions t'.all_scalar_instructions then true @@ -2747,15 +2769,15 @@ end = struct (* disjoint groups: if the key is not in t2, then all insts are not in t2. *) List.for_all - (fun i -> - not - (Instruction.Id.Set.mem (Instruction.id i) - t2.all_scalar_instructions)) + (fun i -> not (contains t2 i)) (Group.scalar_instructions g1)) t1.groups in sub t t' && sub t' t + let compatible t t' deps = + instruction_compatible t t' && register_compatible t t' deps + let select_and_join trees block deps = match trees with | [] -> None @@ -2767,7 +2789,7 @@ end = struct match trees with | [] -> acc | hd :: tl -> - if compatible hd acc + if compatible hd acc deps then let new_acc = join hd acc in if compare_cost new_acc acc < 0 From b084ff3d12937338448f27940e4228f13cae2dad Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Wed, 1 Jan 2025 15:34:11 +0000 Subject: [PATCH 14/30] vectorizer: new test (#3418) Add test for register compatiblity --- .../tests/backend/vectorizer/dune.inc | 79 ++++++++++++++++++- .../tests/backend/vectorizer/gen/gen_dune.ml | 21 +++-- .../test_register_compatible.expected | 1 + .../vectorizer/test_register_compatible.ml | 70 ++++++++++++++++ .../vectorizer/test_register_compatible.mli | 1 + ...er_compatible_vectorized.cmx.dump.expected | 0 6 files changed, 164 insertions(+), 8 deletions(-) create mode 100644 flambda-backend/tests/backend/vectorizer/test_register_compatible.expected create mode 100644 flambda-backend/tests/backend/vectorizer/test_register_compatible.ml create mode 100644 flambda-backend/tests/backend/vectorizer/test_register_compatible.mli create mode 100644 test_register_compatible_vectorized.cmx.dump.expected diff --git a/flambda-backend/tests/backend/vectorizer/dune.inc b/flambda-backend/tests/backend/vectorizer/dune.inc index 64efbe74dc1..67a51f80bb5 100644 --- a/flambda-backend/tests/backend/vectorizer/dune.inc +++ b/flambda-backend/tests/backend/vectorizer/dune.inc @@ -46,7 +46,8 @@ (action (with-outputs-to %{target} - (run %{deps})))) + (with-accepted-exit-codes 0 + (run %{deps}))))) (rule (alias runtest) @@ -73,3 +74,79 @@ (enabled_if (= %{context_name} "main")) (action (diff test1_vectorized.expected test1_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_register_compatible_runner.exe test_register_compatible.cmx.dump) + (deps test_register_compatible.mli test_register_compatible.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -no-vectorize -o test_register_compatible_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_register_compatible.output + (run ./test_register_compatible_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_register_compatible.expected test_register_compatible.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_register_compatible.ml test_register_compatible_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_register_compatible.mli test_register_compatible_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_register_compatible_vectorized_runner.exe test_register_compatible_vectorized.cmx.dump) + (deps test_register_compatible_vectorized.mli test_register_compatible_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize -o test_register_compatible_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_register_compatible_vectorized.cmx.dump.output) + (deps ./filter.sh test_register_compatible_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 1 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_register_compatible_vectorized.cmx.dump.expected test_register_compatible_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_register_compatible_vectorized.output + (run ./test_register_compatible_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_register_compatible.expected test_register_compatible_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_register_compatible_vectorized.expected test_register_compatible_vectorized.output))) diff --git a/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml b/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml index 54784707a27..53062d52b9f 100644 --- a/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml +++ b/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml @@ -98,9 +98,10 @@ let copy_file ~enabled_if name new_name = (copy ${source} ${target}))) |} -let filter_dump ~enabled_if name = +let filter_dump ~enabled_if ~exit_code name = let subst = function | "enabled_if" -> enabled_if + | "exit_code" -> string_of_int exit_code | "dump" -> name |> cmx_dump | "filtered" -> name |> cmx_dump |> output | _ -> assert false @@ -114,7 +115,8 @@ let filter_dump ~enabled_if name = (action (with-outputs-to %{target} - (run %{deps})))) + (with-accepted-exit-codes ${exit_code} + (run %{deps}))))) |} let copy_source_to_vectorize name = @@ -130,8 +132,8 @@ let compile_with_vectorizer name = compile ~enabled_if:enabled_if_main ~extra_flags:"-vectorize" (vectorized name) -let filter_vectorizer_dump ~enabled_if name = - filter_dump ~enabled_if (name |> vectorized) +let filter_vectorizer_dump ~enabled_if ~exit_code name = + filter_dump ~enabled_if ~exit_code (name |> vectorized) let diff_vectorizer_dump ~enabled_if name = diff_output ~enabled_if (name |> vectorized |> cmx_dump) @@ -150,7 +152,7 @@ let copy_expected_output name = copy_file ~enabled_if:enabled_if_main (name |> expected) (name |> vectorized |> expected) -let print_test name = +let print_test ?(filter_exit_code = 0) name = (* check expected test output is up to date *) compile_no_vectorizer name; run_no_vectorizer name; @@ -158,11 +160,16 @@ let print_test name = (* vectorizer *) copy_source_to_vectorize name; compile_with_vectorizer name; - filter_vectorizer_dump name ~enabled_if:enabled_if_main_amd64; + filter_vectorizer_dump name ~exit_code:filter_exit_code + ~enabled_if:enabled_if_main_amd64; diff_vectorizer_dump name ~enabled_if:enabled_if_main_amd64; run_vectorized name; copy_expected_output name; diff_output_vectorized name; () -let () = print_test "test1" +let () = + print_test "test1"; + (* can't vectorize *) + print_test ~filter_exit_code:1 "test_register_compatible"; + () diff --git a/flambda-backend/tests/backend/vectorizer/test_register_compatible.expected b/flambda-backend/tests/backend/vectorizer/test_register_compatible.expected new file mode 100644 index 00000000000..033dec12b51 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_register_compatible.expected @@ -0,0 +1 @@ +make 8 8 diff --git a/flambda-backend/tests/backend/vectorizer/test_register_compatible.ml b/flambda-backend/tests/backend/vectorizer/test_register_compatible.ml new file mode 100644 index 00000000000..479f326d936 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_register_compatible.ml @@ -0,0 +1,70 @@ +(* Cannot vectorize this example because different candidate computations use + the same register as both address and non-address arguments. *) +type s = + | A + | B + +type fn = int -> int + +type r = + { c1 : fn; + c2 : fn + } + +type t = + { d1 : int; + d2 : int; + d3 : int; + d4 : r; + d5 : r; + d6 : int + } + +type r' = + { b0 : s; + b1 : r; + b2 : r + } + +type t' = + { a1 : fn; + a2 : fn; + a3 : fn; + a4 : fn; + a5 : s; + a6 : r; + a7 : r; + a8 : r' + } + +let b0 = Sys.opaque_identity A + +let[@inline never] [@local never] [@specialize never] make t = + let d4 = t.d4 in + let d5 = t.d5 in + let r' = { b1 = d4; b2 = d5; b0 } in + { a1 = d4.c1; + a2 = d4.c2; + a3 = d5.c1; + a4 = d5.c2; + a5 = Sys.opaque_identity A; + a6 = d4; + a7 = d5; + a8 = r' + } + +let print ppf t' = Format.fprintf ppf "%d %d" + +let () = + let t = + { d1 = 1; + d2 = 2; + d3 = 3; + d4 = { c1 = Int.add 1; c2 = Int.mul 3 }; + d5 = { c1 = Int.add 2; c2 = Int.mul 4 }; + d6 = 6 + } + in + let res = make t in + let i = Sys.opaque_identity 7 in + Format.printf "make %d %d\n" (res.a1 i) (res.a6.c1 i) diff --git a/flambda-backend/tests/backend/vectorizer/test_register_compatible.mli b/flambda-backend/tests/backend/vectorizer/test_register_compatible.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_register_compatible.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/test_register_compatible_vectorized.cmx.dump.expected b/test_register_compatible_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..e69de29bb2d From 4de5a72b35063e42dbb1c150ae5af9293f9cecf2 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Thu, 2 Jan 2025 20:10:08 -0500 Subject: [PATCH 15/30] Add `Capsule.with_password` (#3420) --- otherlibs/stdlib_alpha/capsule.ml | 44 +++++++++++----- otherlibs/stdlib_alpha/capsule.mli | 37 ++++++++++---- testsuite/tests/capsule-api/data.ml | 78 +++++++++++++++++++++++++++-- 3 files changed, 132 insertions(+), 27 deletions(-) diff --git a/otherlibs/stdlib_alpha/capsule.ml b/otherlibs/stdlib_alpha/capsule.ml index 73d1bee4777..0bf66090e37 100644 --- a/otherlibs/stdlib_alpha/capsule.ml +++ b/otherlibs/stdlib_alpha/capsule.ml @@ -85,6 +85,8 @@ module Password : sig [void] can't be used for function argument and return types yet. *) type 'k t : value mod portable many unique uncontended + type packed = P : 'k t -> packed + (* Can break the soundness of the API. *) val unsafe_mk : 'k Name.t -> 'k t @@ portable val name : 'k t @ local -> 'k Name.t @@ portable @@ -103,6 +105,8 @@ module Password : sig end = struct type 'k t = 'k Name.t + type packed = P : 'k t -> packed + let unsafe_mk name = name let name t = t @@ -121,9 +125,6 @@ end it never returns is also [portable] *) external reraise : exn -> 'a @ portable @@ portable = "%reraise" -external raise_with_backtrace : - exn -> Printexc.raw_backtrace -> 'a @ portable @@ portable = "%raise_with_backtrace" - module Data = struct type ('a, 'k) t : value mod portable uncontended @@ -377,14 +378,31 @@ let create_with_rwlock () = exception Protected : 'k Mutex.t * (exn, 'k) Data.t -> exn -(* CR-soon mslater: replace with portable stdlib *) -let get_raw_backtrace : unit -> Printexc.raw_backtrace @@ portable = - O.magic O.magic Printexc.get_raw_backtrace - -let protect f = - try f () with - | exn -> - let (P mut) = create_with_mutex () in - raise_with_backtrace (Protected (mut, Data.unsafe_mk exn)) (get_raw_backtrace ()) - ;; +let protect_local f = exclave_ + let (P name) = Name.make () in + let password = Password.unsafe_mk name in + let reraise data = reraise (Protected ({ name; mutex = M.create (); poisoned = false }, data)) in + try f (Password.P password) with + | Encapsulated (inner, data) as exn -> + (match Name.equality_witness name inner with + | Some Equal -> reraise data + | None -> reraise (Data.unsafe_mk exn)) + | exn -> reraise (Data.unsafe_mk exn) + +let with_password_local f = exclave_ + let (P name) = Name.make () in + let password = Password.unsafe_mk name in + try f (Password.P password) with + | Encapsulated (inner, data) as exn -> + (match Name.equality_witness name inner with + | Some Equal -> reraise (Data.unsafe_get data) + | None -> reraise exn) + | exn -> reraise exn + +module Global = struct + type 'a t = { global : 'a @@ global } [@@unboxed] +end +open Global +let protect f = (protect_local (fun password -> { global = f password })).global +let with_password f = (with_password_local (fun password -> { global = f password })).global diff --git a/otherlibs/stdlib_alpha/capsule.mli b/otherlibs/stdlib_alpha/capsule.mli index 23b61a258c9..3373b448e94 100644 --- a/otherlibs/stdlib_alpha/capsule.mli +++ b/otherlibs/stdlib_alpha/capsule.mli @@ -104,6 +104,11 @@ module Password : sig mutex. This guarantees that uncontended access to the capsule is only granted to a single domain at once. *) + type packed = P : 'k t -> packed + (** [packed] is the type of a password for some unknown capsule. + Unpacking one provides a ['k t] together with a fresh existential + type brand for ['k]. *) + val name : 'k t @ local -> 'k Name.t @@ portable (** [name t] identifies the capsule that [t] is associated with. *) @@ -416,15 +421,27 @@ exception Encapsulated : 'k Name.t * (exn, 'k) Data.t -> exn the data. The [Name.t] can be used to associate the [Data.t] with a particular [Password.t] or [Mutex.t]. *) +(* CR-soon mslater: ['k Key.t] instead of ['k Mutex.t]. *) exception Protected : 'k Mutex.t * (exn, 'k) Data.t -> exn (** If a function passed to [protect] raises an exception, it is wrapped - in [Protected] to provide access to the capsule in which the function ran. *) -(* CR-soon mslater: this should return a key, not a mutex. *) - -val protect - : (unit -> 'a @ portable contended) @ local portable - -> 'a @ portable contended - @@ portable -(** [protect f] runs [f] in a fresh capsule. If [f] returns normally, [protect] - merges this capsule into the caller's capsule. If [f] raises, [protect] - raises [Protected], giving the caller access to the encapsulated exception. *) + in [Protected] to avoid leaking access to the data. The [Mutex.t] can + be used to access the [Data.t]. *) + +val protect : (Password.packed @ local -> 'a) @ local portable -> 'a @@ portable +(** [protect f] runs [f password] in a fresh capsule represented by [password]. + If [f] returns normally, [protect] merges the capsule into the caller's capsule. + If [f] raises an [Encapsulated] exception in the capsule represented by [password], + [protect] unwraps the exception and re-raises it as [Protected]. + If [f] raises any other exception, [protect] re-raises it as [Protected]. *) + +val with_password : (Password.packed @ local -> 'a) @ local portable -> 'a @@ portable +(** [with_password f] runs [f password] in a fresh capsule represented by [password]. + If [f] returns normally, [with_password] merges the capsule into the caller's capsule. + If [f] raises an [Encapsulated] exception in the capsule represented by [password], + [with_password] unwraps the exception and re-raises it directly. *) + +val protect_local : (Password.packed @ local -> 'a @ local) @ local portable -> 'a @ local @@ portable +(** See [protect]. *) + +val with_password_local : (Password.packed @ local -> 'a @ local) @ local portable -> 'a @ local @@ portable +(** See [with_password]. *) diff --git a/testsuite/tests/capsule-api/data.ml b/testsuite/tests/capsule-api/data.ml index 9c81c44612f..9e661a4c362 100644 --- a/testsuite/tests/capsule-api/data.ml +++ b/testsuite/tests/capsule-api/data.ml @@ -176,24 +176,55 @@ let () = assert (Capsule.Data.project ptr' = 111) ;; - (* [protect]. *) exception Exn of string let () = - match Capsule.protect (fun () -> "ok") with + match Capsule.protect (fun _password -> "ok") with | s -> assert (s = "ok") | exception _ -> assert false ;; let () = - match Capsule.protect (fun () -> Exn "ok") with + match Capsule.protect (fun _password -> Exn "ok") with | Exn s -> assert (s = "ok") | _ -> assert false ;; let () = - match Capsule.protect (fun () -> reraise (Exn "fail")) with + match Capsule.protect (fun _password -> reraise (Exn "fail")) with + | exception (Capsule.Protected (mut, exn)) -> + let s = Capsule.Mutex.with_lock mut (fun password -> + Capsule.Data.extract password (fun exn -> + match exn with + | Exn s -> s + | _ -> assert false) exn) in + assert (s = "fail") + | _ -> assert false +;; + +let () = + match Capsule.protect (fun (Capsule.Password.P password) -> + let data = Capsule.Data.create (fun () -> "fail") in + let msg = Capsule.Data.extract password (fun s : string -> s) data in + reraise (Exn msg)) + with + | exception (Capsule.Protected (mut, exn)) -> + let s = Capsule.Mutex.with_lock mut (fun password -> + Capsule.Data.extract password (fun exn -> + match exn with + | Exn s -> s + | _ -> assert false) exn) in + assert (s = "fail") + | _ -> assert false +;; + +let () = + match Capsule.protect (fun (Capsule.Password.P password) -> + let data = Capsule.Data.create (fun () -> "fail") in + let () = Capsule.Data.extract password (fun s -> reraise (Exn s)) data in + ()) + with | exception (Capsule.Protected (mut, exn)) -> let s = Capsule.Mutex.with_lock mut (fun password -> Capsule.Data.extract password (fun exn -> @@ -203,3 +234,42 @@ let () = assert (s = "fail") | _ -> assert false ;; + +(* [with_password]. *) +let () = + match Capsule.with_password (fun _password -> "ok") with + | s -> assert (s = "ok") + | exception _ -> assert false +;; + +let () = + match Capsule.with_password (fun _password -> Exn "ok") with + | Exn s -> assert (s = "ok") + | _ -> assert false +;; + +let () = + match Capsule.with_password (fun _password -> reraise (Exn "fail")) with + | exception (Exn s) -> assert (s = "fail") + | _ -> assert false +;; + +let () = + match Capsule.with_password (fun (Capsule.Password.P password) -> + let data = Capsule.Data.create (fun () -> "fail") in + let msg = Capsule.Data.extract password (fun s : string -> s) data in + reraise (Exn msg)) + with + | exception (Exn s) -> assert (s = "fail") + | _ -> assert false +;; + +let () = + match Capsule.with_password (fun (Capsule.Password.P password) -> + let data = Capsule.Data.create (fun () -> "fail") in + let () = Capsule.Data.extract password (fun s -> reraise (Exn s)) data in + ()) + with + | exception (Exn s) -> assert (s = "fail") + | _ -> assert false +;; From a273a33d3fa804275b2755e793c1c4e18468f114 Mon Sep 17 00:00:00 2001 From: Jacob Van Buren Date: Fri, 3 Jan 2025 11:17:18 -0500 Subject: [PATCH 16/30] Changed make fmt to run in parallel (#3422) changed make fmt to run in parallel --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 324f3249b88..13e2765b885 100644 --- a/Makefile +++ b/Makefile @@ -87,7 +87,7 @@ promote: .PHONY: fmt fmt: - ocamlformat -i $$(find . \( -name "*.ml" -or -name "*.mli" \)) + find . \( -name "*.ml" -or -name "*.mli" \) | xargs -P $$(nproc 2>/dev/null || echo 1) -n 20 ocamlformat -i .PHONY: check-fmt check-fmt: From eada0f18e2376e60bba9b6c4423869065360351a Mon Sep 17 00:00:00 2001 From: Ryan Tjoa <51928404+rtjoa@users.noreply.github.com> Date: Fri, 3 Jan 2025 21:23:23 -0500 Subject: [PATCH 17/30] Move unboxed records to stable (#3419) --- jane/doc/extensions/unboxed-types/index.md | 51 +- .../tests/typing-layouts-products/basics.ml | 977 +++++++++++++++- .../basics_unboxed_records.ml} | 3 +- .../typing-layouts-products/exhaustiveness.ml | 31 + .../letrec.ml | 6 +- ..._inline_unboxed_record.compilers.reference | 4 + .../parsing_inline_unboxed_record.ml | 1 - ...ule_dot_unboxed_record.compilers.reference | 4 + .../parsing_module_dot_unboxed_record.ml | 1 - .../recursive.ml | 1 - .../separability.ml | 0 .../typing_misc_unboxed_records.ml | 1 - .../typing_warnings_unboxed_records.ml} | 7 +- .../unboxed_records.ml | 21 +- .../unboxed_records.reference | 0 .../unboxed_records_alpha.ml} | 5 +- ...boxed_records_disabled.compilers.reference | 4 + ...unboxed_records_stable.compilers.reference | 0 .../unique.ml | 4 +- .../unused_unboxed_records.ml} | 7 +- .../basics_from_typing_atat_unboxed.ml | 153 --- .../basics_from_unboxed_tuples_tests.ml | 1017 ----------------- .../disabled.ml | 39 - .../exhaustiveness.ml | 38 - .../modality.ml | 107 -- ..._inline_unboxed_record.compilers.reference | 4 - ...ule_dot_unboxed_record.compilers.reference | 4 - ...boxed_records_disabled.compilers.reference | 4 - testsuite/tests/typing-local/local.ml | 101 ++ testsuite/tests/typing-unboxed-types/test.ml | 130 +++ typing/typecore.ml | 6 +- typing/typedecl.ml | 2 +- 32 files changed, 1292 insertions(+), 1441 deletions(-) rename testsuite/tests/{typing-layouts-unboxed-records/basics.ml => typing-layouts-products/basics_unboxed_records.ml} (99%) rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/letrec.ml (89%) create mode 100644 testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.compilers.reference rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/parsing_inline_unboxed_record.ml (82%) create mode 100644 testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.compilers.reference rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/parsing_module_dot_unboxed_record.ml (87%) rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/recursive.ml (99%) rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/separability.ml (100%) rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/typing_misc_unboxed_records.ml (99%) rename testsuite/tests/{typing-layouts-unboxed-records/typing-warnings.ml => typing-layouts-products/typing_warnings_unboxed_records.ml} (98%) rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/unboxed_records.ml (97%) rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/unboxed_records.reference (100%) rename testsuite/tests/{typing-layouts-unboxed-records/basics_alpha.ml => typing-layouts-products/unboxed_records_alpha.ml} (96%) create mode 100644 testsuite/tests/typing-layouts-products/unboxed_records_disabled.compilers.reference rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/unboxed_records_stable.compilers.reference (100%) rename testsuite/tests/{typing-layouts-unboxed-records => typing-layouts-products}/unique.ml (96%) rename testsuite/tests/{typing-layouts-unboxed-records/unused.ml => typing-layouts-products/unused_unboxed_records.ml} (93%) delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/disabled.ml delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/exhaustiveness.ml delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/modality.ml delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference diff --git a/jane/doc/extensions/unboxed-types/index.md b/jane/doc/extensions/unboxed-types/index.md index 2680d92a41e..27b7c30a7ec 100644 --- a/jane/doc/extensions/unboxed-types/index.md +++ b/jane/doc/extensions/unboxed-types/index.md @@ -225,31 +225,52 @@ modules in the `janestreet_shims` library.) The unboxed product layout describes types that work like normal products (e.g., tuples or records), but which are represented without a box. -In OCaml, a tuple is a pointer to a block containg the elements of the tuple. If +In OCaml, a tuple is a pointer to a block containing the elements of the tuple. If you pass a tuple to a function, it is passed by reference in one register. The -function can access the tuple's elements through the pointer. By contrast, an +function can access the tuple's elements through the pointer. Records and +their fields are treated similarly. By contrast, an unboxed product does not refer to a block at all. When used as a function argument or return type, its elements are passed separately in their own -registers, with no indirection (or on the call stack, if the tuple has more +registers, with no indirection (or on the call stack, if the product has more elements than there are available registers). -Currently the only types that have unboxed product layouts are *unboxed tuples*. -Unboxed tuples are written `#(...)`. So, for example, you can write: +Currently, types that have unboxed product layouts are *unboxed tuples* and +*unboxed records*. + +Unboxed tuples are written `#(...)`, and may have labels just like normal tuples. +So, for example, you can write: ```ocaml module Flipper : sig - val flip : #(int * float# * string) -> #(string * float# * int) + val flip : #(int * float# * lbl:string) -> #(lbl:string * float# * int) end = struct - let flip #(x,y,z) = #(z,y,x) + let flip #(x,y,~lbl:z) = #(~lbl:z,y,x) end ``` -Unboxed tuples may have labels just like normal tuples. There are no limitations -on the layouts of the elements of unboxed tuples, and they may be nested within -themselves. - -*Limitations and future plans*: Unboxed tuples may not currently placed in -blocks. We plan to lift this restriction in the near future. We also plan to add -other types with unboxed product layouts (e.g., unboxed records and interior -pointers). + +Unboxed records are defined, constructed, and matched on like normal records, but with +a leading hash. For example: +```ocaml +type t = #{ f : float# ; s : string } +let inc #{ f ; s } = #{ f = Float_u.add f #1.0 ; s } +``` + +The field names of unboxed records occupy a different namespace from the +field names of "normal" (including `[@@unboxed]`) records. + +Unboxed tuples and records may be nested within other unboxed tuples and records. +There are no limitations on the layouts of the elements of unboxed tuples, but the fields +of unboxed records must be representable. + +*Limitations and future plans*: +- Unboxed products may not currently placed in blocks. + We plan to lift this restriction in the near future. +- Unboxed record fields may not be mutable. + We plan to allow mutating unboxed records within boxed records + (the design will differ from boxed record mutability, as unboxed types don't have the + same notion of identity). +- Unboxed record fields must be representable. + We plan to lift this restriction in the future. +- We plan to add other types with unboxed product layouts (e.g., interior pointers). # The `any` layout diff --git a/testsuite/tests/typing-layouts-products/basics.ml b/testsuite/tests/typing-layouts-products/basics.ml index 8f70d0b47ed..88df08c5294 100644 --- a/testsuite/tests/typing-layouts-products/basics.ml +++ b/testsuite/tests/typing-layouts-products/basics.ml @@ -12,14 +12,16 @@ open Stdlib_upstream_compatible -(**********************************************************) -(* Test 1: Basic unboxed product layouts and tuple types. *) +(****************************************************) +(* Test 1: Basic unboxed product layouts and types. *) type t1 : float64 & value type t2 = #(string * float# * int) +type t2 = #{ s : string; f : float#; i : int } [%%expect{| type t1 : float64 & value type t2 = #(string * float# * int) +type t2 = #{ s : string; f : float#; i : int; } |}] (* You can put unboxed and normal products inside unboxed products *) @@ -30,6 +32,15 @@ type t3 : value & (bits64 & (value & float32)) type t4 = #(string * #(int * (bool * int) * char option)) |}] +type t4_inner2 = #{ b : bool; i : int } +type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option } +type t4 = #{ s : string; t4_inner : t4_inner } +[%%expect{| +type t4_inner2 = #{ b : bool; i : int; } +type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option; } +type t4 = #{ s : string; t4_inner : t4_inner; } +|}] + (* But you can't put unboxed products into normal tuples (yet) *) type t_nope = string * #(string * bool) [%%expect{| @@ -43,6 +54,20 @@ Error: Tuple element types must have layout value. because it's the type of a tuple element. |}] +type t_nope_inner = #{ s : string; b : bool } +type t_nope = string * t_nope_inner +[%%expect{| +type t_nope_inner = #{ s : string; b : bool; } +Line 2, characters 23-35: +2 | type t_nope = string * t_nope_inner + ^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of "t_nope_inner" is value & value + because of the definition of t_nope_inner at line 1, characters 0-45. + But the layout of "t_nope_inner" must be a sublayout of value + because it's the type of a tuple element. +|}] + (********************************************) (* Test 2: Simple kind annotations on types *) @@ -53,6 +78,13 @@ type t1 = #(float# * bool) type t2 = #(string option * t1) |}] +type t1 : float64 & value = #{ f : float#; b : bool } +type t2 : value & (float64 & value) = #{ so : string option ; t1 : t1 } +[%%expect{| +type t1 = #{ f : float#; b : bool; } +type t2 = #{ so : string option; t1 : t1; } +|}] + type t2_wrong : value & float64 & value = #(string option * t1) [%%expect{| Line 1, characters 0-63: @@ -65,6 +97,17 @@ Error: The layout of type "#(string option * t1)" is value & (float64 & value) because of the definition of t2_wrong at line 1, characters 0-63. |}] +type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } +[%%expect{| +Line 1, characters 0-74: +1 | type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The layout of type "t2_wrong" is value & (float64 & value) + because it is an unboxed record. + But the layout of type "t2_wrong" must be a sublayout of value & float64 & value + because of the annotation on the declaration of the type t2_wrong. +|}] + type ('a : value & bits64) t3 = 'a type t4 = #(int * int64#) t3 type t5 = t4 t3 @@ -74,6 +117,17 @@ type t4 = #(int * int64#) t3 type t5 = t4 t3 |}] +type ('a : value & bits64) t3 = 'a +type t4_inner = #{ i : int; i64 : int64# } +type t4 = t4_inner t3 +type t5 = t4 t3 +[%%expect{| +type ('a : value & bits64) t3 = 'a +type t4_inner = #{ i : int; i64 : int64#; } +type t4 = t4_inner t3 +type t5 = t4 t3 +|}] + type t4_wrong = #(int * int) t3 [%%expect{| Line 1, characters 16-28: @@ -89,6 +143,22 @@ Error: This type "#(int * int)" should be an instance of type (* CR layouts v7.1: The above error should identify the component of the product that is problematic. *) +type t4_wrong_inner = #{ i1 : int; i2 : int } +type t4_wrong = t4_wrong_inner t3 +[%%expect{| +type t4_wrong_inner = #{ i1 : int; i2 : int; } +Line 2, characters 16-30: +2 | type t4_wrong = t4_wrong_inner t3 + ^^^^^^^^^^^^^^ +Error: This type "t4_wrong_inner" should be an instance of type + "('a : value & bits64)" + The layout of t4_wrong_inner is value & value + because of the definition of t4_wrong_inner at line 1, characters 0-45. + But the layout of t4_wrong_inner must be a sublayout of value & bits64 + because of the definition of t3 at line 1, characters 0-34. +|}] + + (* some mutually recusive types *) type ('a : value & bits64) t6 = 'a t7 and 'a t7 = { x : 'a t6 } @@ -111,6 +181,29 @@ Error: This type "bool" should be an instance of type "('a : value & bits64)" because of the definition of t6 at line 1, characters 0-37. |}] +type ('a : value & bits64) t6 = 'a t7 +and 'a t7 = { x : 'a t6 } +[%%expect{| +type ('a : value & bits64) t6 = 'a t7 +and ('a : value & bits64) t7 = { x : 'a t6; } +|}] + +type t9_record = #{ i : int; i64 : int64# } +type t9 = t9_record t7 +type t10 = bool t6 +[%%expect{| +type t9_record = #{ i : int; i64 : int64#; } +type t9 = t9_record t7 +Line 3, characters 11-15: +3 | type t10 = bool t6 + ^^^^ +Error: This type "bool" should be an instance of type "('a : value & bits64)" + The layout of bool is value + because it is the primitive type bool. + But the layout of bool must be a sublayout of value & bits64 + because of the definition of t6 at line 1, characters 0-37. +|}] + type ('a : value & bits64) t6_wrong = 'a t7_wrong and 'a t7_wrong = { x : #(int * int64) t6_wrong } [%%expect{| @@ -128,6 +221,23 @@ Error: This type "#(int * int64)" should be an instance of type (* CR layouts v7.1: The above error should identify the component of the product that is problematic. *) +type t6_wrong_inner_record = #{ i : int; i64 : int64 } +and ('a : value & bits64) t6_wrong = 'a t7_wrong +and 'a t7_wrong = { x : t6_wrong_inner_record t6_wrong } +[%%expect{| +Line 1, characters 0-54: +1 | type t6_wrong_inner_record = #{ i : int; i64 : int64 } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of t6_wrong_inner_record is any & any + because it is an unboxed record. + But the layout of t6_wrong_inner_record must be a sublayout of + value & bits64 + because of the annotation on 'a in the declaration of the type + t6_wrong. +|}] +(* CR layouts v7.2: The above has a very bad error message. *) + (* Just like t6/t7, but with the annotation on the other (the order doesn't matter) *) type 'a t11 = 'a t12 @@ -137,6 +247,13 @@ type ('a : value & bits64) t11 = 'a t12 and ('a : value & bits64) t12 = { x : 'a t11; } |}] +type 'a t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11 } +[%%expect{| +type ('a : value & bits64) t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11; } +|}] + (* You can make a universal variable have a product layout, but you have to ask for it *) type ('a : float64 & value) t = 'a @@ -212,6 +329,117 @@ val f_take_a_few_unboxed_tuples : |}] +(* Unboxed records version of the same test *) + +type t1_left = #{ i : int; b : bool } +type t1_right_inner = #{ i64 : int64#; so : string option } +type t1_right = #{ i : int; f : float#; inner : t1_right_inner } +type t1 = t1_left -> t1_right +[%%expect{| +type t1_left = #{ i : int; b : bool; } +type t1_right_inner = #{ i64 : int64#; so : string option; } +type t1_right = #{ i : int; f : float#; inner : t1_right_inner; } +type t1 = t1_left -> t1_right +|}] + +type make_record_result = #{ f : float#; s : string } +let f_make_an_unboxed_record (x : string) (y : float#) = #{ f = y; s = x } + +type inner = #{ f1 : float#; f2 : float# } +type t = #{ s : string; inner : inner } +let f_pull_apart_an_unboxed_record (x : t) = + match x with + | #{ s; inner = #{ f1; f2 } } -> + if s = "mul" then + Float_u.mul f1 f2 + else + Float_u.add f1 f2 +[%%expect{| +type make_record_result = #{ f : float#; s : string; } +val f_make_an_unboxed_record : string -> float# -> make_record_result = +type inner = #{ f1 : float#; f2 : float#; } +type t = #{ s : string; inner : inner; } +val f_pull_apart_an_unboxed_record : + t -> Stdlib_upstream_compatible.Float_u.t = +|}] + + +module type S = sig + type a + type b + type c + type d + type e + type f + type g + type h +end + +module F(X : S) = struct + include X + type mix_input_inner2 = #{ d : d; e : e } + type mix_input_inner = #{ c : c; inner2 : mix_input_inner2 } + type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f } + type mix_output_inner2 = #{ f : f; e : e } + type mix_output_inner = #{ c : c; inner2 : mix_output_inner2 } + type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d } + let f_mix_up_an_unboxed_record (x : mix_input) = + let #{ a; b; inner = #{ c; inner2 = #{ d; e } }; f } = x in + #{ b = b; inner = #{ c = c; inner2 = #{ f = f; e = e } }; a = a; d = d } + + type take_few_input1 = #{ a : a; b : b } + type take_few_input3 = #{ d : d; e : e } + type take_few_input5 = #{ g : g; h : h } + type take_few_output = + #{ h : h; g2 : g; x4 : f; e2 : e; d : d; x2 : c; b : b; a2 : a } + + let f_take_a_few_unboxed_records (x1 : take_few_input1) x2 + (x3 : take_few_input3) x4 (x5 : take_few_input5) = + let #{ a; b } = x1 in + let #{ d; e } = x3 in + let #{ g; h } = x5 in + #{ h = h; g2 = g; x4 = x4; e2 = e; d = d; x2 = x2; b = b; a2 = a } +end +[%%expect{| +module type S = + sig type a type b type c type d type e type f type g type h end +module F : + functor (X : S) -> + sig + type a = X.a + type b = X.b + type c = X.c + type d = X.d + type e = X.e + type f = X.f + type g = X.g + type h = X.h + type mix_input_inner2 = #{ d : d; e : e; } + type mix_input_inner = #{ c : c; inner2 : mix_input_inner2; } + type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f; } + type mix_output_inner2 = #{ f : f; e : e; } + type mix_output_inner = #{ c : c; inner2 : mix_output_inner2; } + type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d; } + val f_mix_up_an_unboxed_record : mix_input -> mix_output + type take_few_input1 = #{ a : a; b : b; } + type take_few_input3 = #{ d : d; e : e; } + type take_few_input5 = #{ g : g; h : h; } + type take_few_output = #{ + h : h; + g2 : g; + x4 : f; + e2 : e; + d : d; + x2 : c; + b : b; + a2 : a; + } + val f_take_a_few_unboxed_records : + take_few_input1 -> + c -> take_few_input3 -> f -> take_few_input5 -> take_few_output + end +|}] + (***************************************************) (* Test 4: Unboxed products don't go in structures *) @@ -373,6 +601,194 @@ Error: This expression has type "('a : value_or_null)" But the layout of #('a * 'b) must be a sublayout of value because it's the type of a variable captured in an object. |}];; + +(* Unboxed records version of the same test *) + +type poly_var_inner = #{ i : int; b : bool } +type poly_var_type = [ `Foo of poly_var_inner ] +[%%expect{| +type poly_var_inner = #{ i : int; b : bool; } +Line 2, characters 31-45: +2 | type poly_var_type = [ `Foo of poly_var_inner ] + ^^^^^^^^^^^^^^ +Error: Polymorphic variant constructor argument types must have layout value. + The layout of "poly_var_inner" is value & value + because of the definition of poly_var_inner at line 1, characters 0-44. + But the layout of "poly_var_inner" must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +type poly_var_term_record = #{ i : int; i2 : int } +let poly_var_term = `Foo #{ i = 1; i2 = 2 } +[%%expect{| +type poly_var_term_record = #{ i : int; i2 : int; } +Line 2, characters 25-43: +2 | let poly_var_term = `Foo #{ i = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^ +Error: This expression has type "poly_var_term_record" + but an expression was expected of type "('a : value_or_null)" + The layout of poly_var_term_record is value & value + because of the definition of poly_var_term_record at line 1, characters 0-50. + But the layout of poly_var_term_record must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +type record_inner = #{ b : bool; f : float# } +type tuple_type = (int * record_inner) +[%%expect{| +type record_inner = #{ b : bool; f : float#; } +Line 2, characters 25-37: +2 | type tuple_type = (int * record_inner) + ^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of "record_inner" is value & float64 + because of the definition of record_inner at line 1, characters 0-45. + But the layout of "record_inner" must be a sublayout of value + because it's the type of a tuple element. +|}] + +type record = #{ i : int; i2 : int } +let tuple_term = ("hi", #{ i = 1; i2 = 2 }) +[%%expect{| +type record = #{ i : int; i2 : int; } +Line 2, characters 24-42: +2 | let tuple_term = ("hi", #{ i = 1; i2 = 2 }) + ^^^^^^^^^^^^^^^^^^ +Error: This expression has type "record" but an expression was expected of type + "('a : value_or_null)" + The layout of record is value & value + because of the definition of record at line 1, characters 0-36. + But the layout of record must be a sublayout of value + because it's the type of a tuple element. +|}] + +type record_inner = #{ i : int; b : bool } +type record = { x : record_inner } +[%%expect{| +type record_inner = #{ i : int; b : bool; } +Line 2, characters 0-34: +2 | type record = { x : record_inner } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "record_inner" has layout "value & value". + Records may not yet contain types of this layout. +|}] + +type inlined_inner = #{ i : int; b : bool } +type inlined_record = A of { x : inlined_inner } +[%%expect{| +type inlined_inner = #{ i : int; b : bool; } +Line 2, characters 22-48: +2 | type inlined_record = A of { x : inlined_inner } + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "inlined_inner" has layout "value & value". + Inlined records may not yet contain types of this layout. +|}] + +type variant_inner = #{ i : int; b : bool } +type variant = A of variant_inner +[%%expect{| +type variant_inner = #{ i : int; b : bool; } +Line 2, characters 15-33: +2 | type variant = A of variant_inner + ^^^^^^^^^^^^^^^^^^ +Error: Type "variant_inner" has layout "value & value". + Variants may not yet contain types of this layout. +|}] + +type sig_inner = #{ i : int; b : bool } +module type S = sig + val x : sig_inner +end +[%%expect{| +type sig_inner = #{ i : int; b : bool; } +Line 3, characters 10-19: +3 | val x : sig_inner + ^^^^^^^^^ +Error: This type signature for "x" is not a value type. + The layout of type sig_inner is value & value + because of the definition of sig_inner at line 1, characters 0-39. + But the layout of type sig_inner must be a sublayout of value + because it's the type of something stored in a module structure. +|}] + +type m_record = #{ i1 : int; i2 : int } +module M = struct + let x = #{ i1 = 1; i2 = 2 } +end +[%%expect{| +type m_record = #{ i1 : int; i2 : int; } +Line 3, characters 6-7: +3 | let x = #{ i1 = 1; i2 = 2 } + ^ +Error: Types of top-level module bindings must have layout "value", but + the type of "x" has layout "value & value". +|}] + +type object_inner = #{ i : int; b : bool } +type object_type = < x : object_inner > +[%%expect{| +type object_inner = #{ i : int; b : bool; } +Line 2, characters 21-37: +2 | type object_type = < x : object_inner > + ^^^^^^^^^^^^^^^^ +Error: Object field types must have layout value. + The layout of "object_inner" is value & value + because of the definition of object_inner at line 1, characters 0-42. + But the layout of "object_inner" must be a sublayout of value + because it's the type of an object field. +|}] + +type object_term_record = #{ i1 : int; i2 : int } +let object_term = object val x = #{ i1 = 1; i2 = 2 } end +[%%expect{| +type object_term_record = #{ i1 : int; i2 : int; } +Line 2, characters 29-30: +2 | let object_term = object val x = #{ i1 = 1; i2 = 2 } end + ^ +Error: Variables bound in a class must have layout value. + The layout of x is value & value + because of the definition of object_term_record at line 1, characters 0-49. + But the layout of x must be a sublayout of value + because it's the type of a class field. +|}] + +type class_record = #{ i1 : int; i2 : int } +class class_ = + object + method x = #{ i1 = 1; i2 = 2 } + end +[%%expect{| +type class_record = #{ i1 : int; i2 : int; } +Line 4, characters 15-34: +4 | method x = #{ i1 = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "class_record" + but an expression was expected of type "('a : value)" + The layout of class_record is value & value + because of the definition of class_record at line 1, characters 0-43. + But the layout of class_record must be a sublayout of value + because it's the type of an object field. +|}] + +type capture_record = #{ x : int; y : int } +let capture_in_object utup = object + val f = fun () -> + let #{ x; y } = utup in + x + y +end;; +[%%expect{| +type capture_record = #{ x : int; y : int; } +Line 4, characters 20-24: +4 | let #{ x; y } = utup in + ^^^^ +Error: This expression has type "('a : value_or_null)" + but an expression was expected of type "capture_record" + The layout of capture_record is value & value + because of the definition of capture_record at line 1, characters 0-43. + But the layout of capture_record must be a sublayout of value + because it's the type of a variable captured in an object. +|}];; + (****************************************************) (* Test 5: Methods may take/return unboxed products *) @@ -385,6 +801,23 @@ class class_with_utuple_manipulating_method : object method f : #(int * int) -> #(int * int) -> #(int * int) end |}] +type method_input = #{ a : int; b : int } +type method_output = #{ sum_a : int; sum_b : int } + +class class_with_urecord_manipulating_method = + object + method f (x : method_input) (y : method_input) = + let #{ a; b } = x in + let #{ a = c; b = d } = y in + #{ sum_a = a + c; sum_b = b + d } + end +[%%expect{| +type method_input = #{ a : int; b : int; } +type method_output = #{ sum_a : int; sum_b : int; } +class class_with_urecord_manipulating_method : + object method f : method_input -> method_input -> method_output end +|}] + (*******************************************) (* Test 6: Nested expansion in kind checks *) @@ -504,8 +937,43 @@ module F : sig type r = X.t4 t_constraint end |}] -(***********************************************) -(* Test 7: modal kinds for unboxed tuple types *) +(* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and + boxed records, in the same way as below. + + CR layouts v7.2: These should typecheck for all record forms. +*) +module type S_coherence_deep = sig + type t1 : any + type t2 = #{ i : int; t1 : t1 } +end +[%%expect{| +Line 3, characters 24-31: +3 | type t2 = #{ i : int; t1 : t1 } + ^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 2, characters 2-15. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +module type S_coherence_deep = sig + type t1 : any + type t2 = { t1 : t1 } [@@unboxed] +end +[%%expect{| +Line 3, characters 14-21: +3 | type t2 = { t1 : t1 } [@@unboxed] + ^^^^^^^ +Error: [@@unboxed] record element types must have a representable layout. + The layout of t1/2 is any + because of the definition of t1 at line 2, characters 2-15. + But the layout of t1/2 must be representable + because it is the type of record field t1. +|}] + +(*************************************************) +(* Test 7: modal kinds for unboxed product types *) let f_external_utuple_mode_crosses_local_1 : local_ #(int * int) -> #(int * int) = fun x -> x @@ -559,6 +1027,80 @@ Line 3, characters 67-68: Error: This value escapes its region. |}] +(* Unboxed records version of the same test *) + +type local_cross1 = #{ i1 : int; i2 : int } +let f_external_urecord_mode_crosses_local_1 + : local_ local_cross1 -> local_cross1 = fun x -> x +[%%expect{| +type local_cross1 = #{ i1 : int; i2 : int; } +val f_external_urecord_mode_crosses_local_1 : + local_ local_cross1 -> local_cross1 = +|}] + +type local_nocross1 = #{ i : int; s : string } +let f_internal_urecord_does_not_mode_cross_local_1 + : local_ local_nocross1 -> local_nocross1 = fun x -> x +[%%expect{| +type local_nocross1 = #{ i : int; s : string; } +Line 3, characters 55-56: +3 | : local_ local_nocross1 -> local_nocross1 = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type local_cross2_inner = #{ b : bool; i : int } +type local_cross2 = #{ i : int; inner : local_cross2_inner } +let f_external_urecord_mode_crosses_local_2 + : local_ local_cross2 -> local_cross2 = fun x -> x +[%%expect{| +type local_cross2_inner = #{ b : bool; i : int; } +type local_cross2 = #{ i : int; inner : local_cross2_inner; } +val f_external_urecord_mode_crosses_local_2 : + local_ local_cross2 -> local_cross2 = +|}] + +type local_nocross2_inner = #{ b : bool; s : string } +type local_nocross2 = #{ i : int; inner : local_nocross2_inner } +let f_internal_urecord_does_not_mode_cross_local_2 + : local_ local_nocross2 -> local_nocross2 = fun x -> x +[%%expect{| +type local_nocross2_inner = #{ b : bool; s : string; } +type local_nocross2 = #{ i : int; inner : local_nocross2_inner; } +Line 4, characters 55-56: +4 | : local_ local_nocross2 -> local_nocross2 = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type t = #{ i1 : int; i2 : int } +type local_cross3_inner = #{ t : t; i : int } +type local_cross3 = #{ i : int; inner : local_cross3_inner } +let f_external_urecord_mode_crosses_local_3 + : local_ local_cross3 -> local_cross3 = fun x -> x +[%%expect{| +type t = #{ i1 : int; i2 : int; } +type local_cross3_inner = #{ t : t; i : int; } +type local_cross3 = #{ i : int; inner : local_cross3_inner; } +val f_external_urecord_mode_crosses_local_3 : + local_ local_cross3 -> local_cross3 = +|}] + +type t = #{ s : string; i : int } +type local_nocross3_inner = #{ t : t; b : bool } +type local_nocross3 = #{ i : int; inner : local_nocross3_inner } +let f_internal_urecord_does_not_mode_cross_local_3 + : local_ local_nocross3 -> local_nocross3 = fun x -> x +[%%expect{| +type t = #{ s : string; i : int; } +type local_nocross3_inner = #{ t : t; b : bool; } +type local_nocross3 = #{ i : int; inner : local_nocross3_inner; } +Line 5, characters 55-56: +5 | : local_ local_nocross3 -> local_nocross3 = fun x -> x + ^ +Error: This value escapes its region. +|}] + (****************************************************) (* Test 8: modal kinds for product kind annotations *) @@ -692,10 +1234,112 @@ external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] val sum : int = 3 |}] +(* Unboxed records version of the same test *) + +type t_product : value & value + +type ext_record_arg_record = #{ i : int; b : bool } +external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" +[%%expect{| +type t_product : value & value +type ext_record_arg_record = #{ i : int; b : bool; } +Line 4, characters 26-54: +4 | external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +type ext_record_arg_attr_record = #{ i : int; b : bool } +external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" +[%%expect{| +type ext_record_arg_attr_record = #{ i : int; b : bool; } +Line 2, characters 37-63: +2 | external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external ext_product_arg : t_product -> int = "foo" "bar" +[%%expect{| +Line 1, characters 27-43: +1 | external ext_product_arg : t_product -> int = "foo" "bar" + ^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" +[%%expect{| +Line 1, characters 38-47: +1 | external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" + ^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +type t = #{ i : int; b : bool } +external ext_record_return : int -> t = "foo" "bar" +[%%expect{| +type t = #{ i : int; b : bool; } +Line 2, characters 29-37: +2 | external ext_record_return : int -> t = "foo" "bar" + ^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +type t = #{ i : int; b : bool } +external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" +[%%expect{| +type t = #{ i : int; b : bool; } +Line 2, characters 47-48: +2 | external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" + ^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external ext_product_return : int -> t_product = "foo" "bar" +[%%expect{| +Line 1, characters 30-46: +1 | external ext_product_return : int -> t_product = "foo" "bar" + ^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" +[%%expect{| +Line 1, characters 48-57: +1 | external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" + ^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external[@layout_poly] id : ('a : any). 'a -> 'a = "%identity" + +type id_record = #{ x : int; y : int } +let sum = + let #{ x; y } = id #{ x = 1; y = 2 } in + x + y +[%%expect{| +external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] +type id_record = #{ x : int; y : int; } +val sum : int = 3 +|}] + + (***********************************) -(* Test 9: not allowed in let recs *) +(* Test 10: not allowed in let recs *) -(* An example that is allowed on tuples but not unboxed tuples *) +(* An example that is allowed on tuples but not unboxed products *) let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () let[@warning "-26"] e2 = let rec x = #(1, y) and y = 42 in () [%%expect{| @@ -711,7 +1355,36 @@ Error: This expression has type "#('a * 'b)" because it's the type of the recursive variable x. |}] -(* This example motivates having a check in [type_let], because +let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () + +type letrec_record = #{ i1 : int; i2 : int } +let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () +[%%expect{| +val e1 : unit = () +type letrec_record = #{ i1 : int; i2 : int; } +Line 4, characters 37-56: +4 | let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "letrec_record" + but an expression was expected of type "('a : value_or_null)" + The layout of letrec_record is value & value + because of the definition of letrec_record at line 3, characters 0-44. + But the layout of letrec_record must be a sublayout of value + because it's the type of the recursive variable x. +|}] + +(* Unboxed records of kind value are also disallowed: *) +type letrec_record = #{ i : int } +let e2 = let rec x = #{ i = y } and y = 42 in () +[%%expect{| +type letrec_record = #{ i : int; } +Line 2, characters 21-31: +2 | let e2 = let rec x = #{ i = y } and y = 42 in () + ^^^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}] + +(* These examples motivate having a check in [type_let], because [Value_rec_check] is not set up to reject it, but we don't support even this limited form of unboxed let rec (yet). *) let _ = let rec _x = #(3, 10) and _y = 42 in 42 @@ -727,8 +1400,23 @@ Error: This expression has type "#('a * 'b)" because it's the type of the recursive variable _x. |}] +type letrec_simple = #{ i1 : int; i2 : int } +let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 +[%%expect{| +type letrec_simple = #{ i1 : int; i2 : int; } +Line 2, characters 21-41: +2 | let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "letrec_simple" + but an expression was expected of type "('a : value_or_null)" + The layout of letrec_simple is value & value + because of the definition of letrec_simple at line 1, characters 0-44. + But the layout of letrec_simple must be a sublayout of value + because it's the type of the recursive variable _x. +|}] + (**********************************************************) -(* Test 10: not allowed in [@@unboxed] declarations (yet) *) +(* Test 11: not allowed in [@@unboxed] declarations (yet) *) type ('a : value & value) t = A of 'a [@@unboxed] [%%expect{| @@ -766,8 +1454,53 @@ Error: Type "#(int * int)" has layout "value & value". [@@unboxed] inlined records may not yet contain types of this layout. |}] +type unboxed_record = #{ i1 : int; i2 : int } +type t = A of unboxed_record [@@unboxed] +[%%expect{| +type unboxed_record = #{ i1 : int; i2 : int; } +Line 2, characters 9-28: +2 | type t = A of unboxed_record [@@unboxed] + ^^^^^^^^^^^^^^^^^^^ +Error: Type "unboxed_record" has layout "value & value". + Unboxed variants may not yet contain types of this layout. +|}] + +type ('a : value & value) t = A of { x : 'a } [@@unboxed] +[%%expect{| +Line 1, characters 37-43: +1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] + ^^^^^^ +Error: Type "'a" has layout "value & value". + [@@unboxed] inlined records may not yet contain types of this layout. +|}] + +type unboxed_inline_record = #{ i1 : int; i2 : int } +type t = A of { x : unboxed_inline_record } [@@unboxed] +[%%expect{| +type unboxed_inline_record = #{ i1 : int; i2 : int; } +Line 2, characters 16-41: +2 | type t = A of { x : unboxed_inline_record } [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "unboxed_inline_record" has layout "value & value". + [@@unboxed] inlined records may not yet contain types of this layout. +|}] + +(* Unboxed records of kind value are allowed *) + +type unboxed_record = #{ i : int } +type t = A of unboxed_record [@@unboxed] +[%%expect{| +type unboxed_record = #{ i : int; } +type t = A of unboxed_record [@@unboxed] +|}] + +type t = A of { x : unboxed_record } [@@unboxed] +[%%expect{| +type t = A of { x : unboxed_record; } [@@unboxed] +|}] + (**************************************) -(* Test 11: Unboxed tuples and arrays *) +(* Test 12: Unboxed tuples and arrays *) (* You can write the type of an array of unboxed tuples, but not create one. Soon, you can do both. *) @@ -860,9 +1593,69 @@ Error: Non-value layout value & value detected as sort for type #(int * int), Otherwise, please report this error to the Jane Street compilers team. |}] +(* You can write the type of an array of unboxed records, but not create + one. Soon, you can do both. *) +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array + +type t3_record = #{ i : int; b : bool } +type t3 = t3_record array + +type t4_inner = #{ f : float#; bo : bool option } +type t4_record = #{ s : string; inner : t4_inner } +type t4 = t4_record array +[%%expect{| +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array +type t3_record = #{ i : int; b : bool; } +type t3 = t3_record array +type t4_inner = #{ f : float#; bo : bool option; } +type t4_record = #{ s : string; inner : t4_inner; } +type t4 = t4_record array +|}] + +type array_record = #{ i1 : int; i2 : int } +let _ = [| #{ i1 = 1; i2 = 2 } |] +[%%expect{| +type array_record = #{ i1 : int; i2 : int; } +Line 2, characters 8-33: +2 | let _ = [| #{ i1 = 1; i2 = 2 } |] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Non-value layout value & value detected as sort for type array_record, + but this requires extension layouts_alpha, which is not enabled. + If you intended to use this layout, please add this flag to your build file. + Otherwise, please report this error to the Jane Street compilers team. +|}] + +type array_init_record = #{ i1 : int; i2 : int } +let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) +[%%expect{| +type array_init_record = #{ i1 : int; i2 : int; } +Line 2, characters 31-50: +2 | let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "array_init_record" + but an expression was expected of type "('a : value)" + The layout of array_init_record is value & value + because of the definition of array_init_record at line 1, characters 0-48. + But the layout of array_init_record must be a sublayout of value. +|}] + +(* Arrays of unboxed records of kind value *are* allowed *) +type array_record = #{ i : int } +let _ = [| #{ i = 1 } |] +[%%expect{| +type array_record = #{ i : int; } +- : array_record array = [|#{i = 1}|] +|}] + +let _ = Array.init 3 (fun i -> #{ i }) +[%%expect{| +- : array_record array = [|#{i = 0}; #{i = 1}; #{i = 2}|] +|}] (***********************************************************) -(* Test 12: Unboxed products are not allowed as class args *) +(* Test 13: Unboxed products are not allowed as class args *) class product_instance_variable x = let sum = let #(a,b) = x in a + b in @@ -881,8 +1674,40 @@ Error: This expression has type "('a : value)" because it's the type of a term-level argument to a class constructor. |}] +type class_arg_record = #{ a : int; b : int } +class product_instance_variable x = + let sum = let #{ a; b } = x in a + b in + object + method y = sum + end;; +[%%expect{| +type class_arg_record = #{ a : int; b : int; } +Line 3, characters 28-29: +3 | let sum = let #{ a; b } = x in a + b in + ^ +Error: This expression has type "('a : value)" + but an expression was expected of type "class_arg_record" + The layout of class_arg_record is value & value + because of the definition of class_arg_record at line 1, characters 0-45. + But the layout of class_arg_record must be a sublayout of value + because it's the type of a term-level argument to a class constructor. +|}] + +(* But unboxed records of kind value are: *) +type class_arg_record = #{ a : string } +class product_instance_variable x = + let s = let #{ a } = x in a in + object + method y = s + end;; +[%%expect{| +type class_arg_record = #{ a : string; } +class product_instance_variable : + class_arg_record -> object method y : string end +|}] + (*****************************************) -(* Test 13: No lazy unboxed products yet *) +(* Test 14: No lazy unboxed products yet *) let x = lazy #(1,2) @@ -911,8 +1736,52 @@ Error: This type "#(int * int)" should be an instance of type "('a : value)" because the type argument of lazy_t has layout value. |}] +type lazy_record = #{ i1 : int; i2 : int } +let x = lazy #{ i1 = 1; i2 = 2 } +[%%expect{| +type lazy_record = #{ i1 : int; i2 : int; } +Line 2, characters 13-32: +2 | let x = lazy #{ i1 = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "lazy_record" + but an expression was expected of type "('a : value)" + The layout of lazy_record is value & value + because of the definition of lazy_record at line 1, characters 0-42. + But the layout of lazy_record must be a sublayout of value + because it's the type of a lazy expression. +|}] + +type lazy_t_record = #{ i1 : int; i2 : int } +type t = lazy_t_record lazy_t +[%%expect{| +type lazy_t_record = #{ i1 : int; i2 : int; } +Line 2, characters 9-22: +2 | type t = lazy_t_record lazy_t + ^^^^^^^^^^^^^ +Error: This type "lazy_t_record" should be an instance of type "('a : value)" + The layout of lazy_t_record is value & value + because of the definition of lazy_t_record at line 1, characters 0-44. + But the layout of lazy_t_record must be a sublayout of value + because the type argument of lazy_t has layout value. +|}] + +(* Again, unboxed records of kind value can be: *) + +type t = #{ i : int } +let x = lazy #{ i = 1 } +[%%expect{| +type t = #{ i : int; } +val x : t lazy_t = +|}] + +type t2 = t lazy_t +[%%expect{| +type t2 = t lazy_t +|}] + + (***************************************) -(* Test 14: Coercions work covariantly *) +(* Test 15: Coercions work covariantly *) type t = private int @@ -932,8 +1801,26 @@ Error: Type "#(int * int)" is not a subtype of "#(t * t)" Type "int" is not a subtype of "t" |}] +(* Unboxed records can't be coerced *) + +type t = private int + +type coerce_record = #{ t1 : t; t2 : t } +type coerce_int_record = #{ i1 : int; i2 : int } +let f (x : coerce_record) = + let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b +[%%expect{| +type t = private int +type coerce_record = #{ t1 : t; t2 : t; } +type coerce_int_record = #{ i1 : int; i2 : int; } +Line 6, characters 28-52: +6 | let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "coerce_record" is not a subtype of "coerce_int_record" +|}] + (************************************************) -(* Test 15: Not allowed as an optional argument *) +(* Test 16: Not allowed as an optional argument *) let f_optional_utuple ?(x = #(1,2)) () = x [%%expect{| @@ -948,8 +1835,23 @@ Error: This expression has type "#('a * 'b)" because the type argument of option has layout value. |}] +type optional_record = #{ i1 : int; i2 : int } +let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x +[%%expect{| +type optional_record = #{ i1 : int; i2 : int; } +Line 2, characters 29-48: +2 | let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "optional_record" + but an expression was expected of type "('a : value)" + The layout of optional_record is value & value + because of the definition of optional_record at line 1, characters 0-46. + But the layout of optional_record must be a sublayout of value + because the type argument of option has layout value. +|}] + (******************************) -(* Test 16: Decomposing [any] *) +(* Test 17: Decomposing [any] *) type ('a : value) u = U of 'a [@@unboxed] type ('a : value) t = #('a u * 'a u) @@ -998,8 +1900,53 @@ Error: This type "#(int * string * int)" should be an instance of type |}] (* CR layouts v7.1: The appearance of [immutable_data] above is regrettable. *) +type ('a : value) u = U of 'a [@@unboxed] +type ('a : value) t = #{ u1 : 'a u; u2 : 'a u } + +type ('a : any mod global) needs_any_mod_global + +type should_work = int t needs_any_mod_global +[%%expect{| +type 'a u = U of 'a [@@unboxed] +type 'a t = #{ u1 : 'a u; u2 : 'a u; } +type ('a : any mod global) needs_any_mod_global +type should_work = int t needs_any_mod_global +|}] + +type should_fail = string t needs_any_mod_global +[%%expect{| +Line 1, characters 19-27: +1 | type should_fail = string t needs_any_mod_global + ^^^^^^^^ +Error: This type "string t" should be an instance of type "('a : any mod global)" + The kind of string t is value & value + because of the definition of t at line 2, characters 0-47. + But the kind of string t must be a subkind of any mod global + because of the definition of needs_any_mod_global at line 4, characters 0-47. +|}] + +type ('a : any mod external_) t + +type s_record = #{ i1 : int; s : string; i2 : int } +type s = s_record t +[%%expect{| +type ('a : any mod external_) t +type s_record = #{ i1 : int; s : string; i2 : int; } +Line 4, characters 9-17: +4 | type s = s_record t + ^^^^^^^^ +Error: This type "s_record" should be an instance of type + "('a : any mod external_)" + The kind of s_record is + immutable_data & immutable_data & immutable_data + because of the definition of s_record at line 3, characters 0-51. + But the kind of s_record must be a subkind of any mod external_ + because of the definition of t at line 1, characters 0-31. +|}] +(* CR layouts v7.1: Both the above have very bad error messages. *) + (********************************************) -(* Test 17: Subkinding with sorts and [any] *) +(* Test 18: Subkinding with sorts and [any] *) (* CR layouts: Change to use [any] instead of [any_non_null] when doing so won't cause trouble with the [alpha] check. *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-products/basics_unboxed_records.ml similarity index 99% rename from testsuite/tests/typing-layouts-unboxed-records/basics.ml rename to testsuite/tests/typing-layouts-products/basics_unboxed_records.ml index 2827e5b0d71..5f6726da4dc 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-products/basics_unboxed_records.ml @@ -1,7 +1,6 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha"; { expect; } @@ -682,7 +681,7 @@ val update_t : t -> unit = type ('a : any) t = #{ x : int; y : 'a } [%%expect{| -type ('a : value_or_null) t = #{ x : int; y : 'a; } +type 'a t = #{ x : int; y : 'a; } |}] (* CR layouts v7.2: once we allow record declarations with unknown kind (right diff --git a/testsuite/tests/typing-layouts-products/exhaustiveness.ml b/testsuite/tests/typing-layouts-products/exhaustiveness.ml index 289088f5ea6..f7601c696fe 100644 --- a/testsuite/tests/typing-layouts-products/exhaustiveness.ml +++ b/testsuite/tests/typing-layouts-products/exhaustiveness.ml @@ -16,3 +16,34 @@ let f t t' = type t = A | B val f : t -> 'a -> bool = |}] + +type t = A | B +type r = #{ x : t; y : t } + +let f t t' = + match #{ x = t; y = t' } with + | #{ x = A; y = _ } -> true + | #{ x = B; y = _ } -> false +[%%expect{| +type t = A | B +type r = #{ x : t; y : t; } +val f : t -> t -> bool = +|}] + +(* This is a regression test. The example below used to give + #{y=A; _ } as a counterexample instead of #{y=A; x=B}. *) +let g t t' = + match #{ x = t; y = t' } with + | #{ x = A; _ } -> true + | #{ y = B; _ } -> false +[%%expect{| +Lines 2-4, characters 2-26: +2 | ..match #{ x = t; y = t' } with +3 | | #{ x = A; _ } -> true +4 | | #{ y = B; _ } -> false +Warning 8 [partial-match]: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +#{y=A; x=B} + +val g : t -> t -> bool = +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml b/testsuite/tests/typing-layouts-products/letrec.ml similarity index 89% rename from testsuite/tests/typing-layouts-unboxed-records/letrec.ml rename to testsuite/tests/typing-layouts-products/letrec.ml index 847b2fa41a6..5e0afabb196 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml +++ b/testsuite/tests/typing-layouts-products/letrec.ml @@ -1,7 +1,6 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; { expect; } @@ -34,10 +33,7 @@ let rec t = { bx = #{ ubx = t } } val t : bx = {bx = } |}] -(* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) +(* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml]. *) type t = #{x: int64} let rec x = #{x = y} and y = 3L;; diff --git a/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.compilers.reference new file mode 100644 index 00000000000..174e4975100 --- /dev/null +++ b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_inline_unboxed_record.ml", line 10, characters 22-24: +10 | type variant = Foo of #{ x : string } + ^^ +Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.ml similarity index 82% rename from testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml rename to testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.ml index 5540637473e..9a4052ecef1 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml +++ b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.ml @@ -1,5 +1,4 @@ (* TEST - flags = "-extension-universe beta"; setup-ocamlc.byte-build-env; ocamlc_byte_exit_status = "2"; ocamlc.byte; diff --git a/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.compilers.reference new file mode 100644 index 00000000000..7c389fd11e2 --- /dev/null +++ b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_module_dot_unboxed_record.ml", line 14, characters 11-12: +14 | let t = M.#{ i = 1 } + ^ +Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.ml similarity index 87% rename from testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml rename to testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.ml index 0309a84c82a..fdbd7a50dcc 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml +++ b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.ml @@ -1,5 +1,4 @@ (* TEST - flags = "-extension-universe beta"; setup-ocamlc.byte-build-env; ocamlc_byte_exit_status = "2"; ocamlc.byte; diff --git a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml b/testsuite/tests/typing-layouts-products/recursive.ml similarity index 99% rename from testsuite/tests/typing-layouts-unboxed-records/recursive.ml rename to testsuite/tests/typing-layouts-products/recursive.ml index a9e00527391..0ff208ffbc5 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml +++ b/testsuite/tests/typing-layouts-products/recursive.ml @@ -1,7 +1,6 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; { expect; } diff --git a/testsuite/tests/typing-layouts-unboxed-records/separability.ml b/testsuite/tests/typing-layouts-products/separability.ml similarity index 100% rename from testsuite/tests/typing-layouts-unboxed-records/separability.ml rename to testsuite/tests/typing-layouts-products/separability.ml diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml b/testsuite/tests/typing-layouts-products/typing_misc_unboxed_records.ml similarity index 99% rename from testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml rename to testsuite/tests/typing-layouts-products/typing_misc_unboxed_records.ml index a15c7fddaa4..01bfbc96624 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml +++ b/testsuite/tests/typing-layouts-products/typing_misc_unboxed_records.ml @@ -1,5 +1,4 @@ (* TEST - flags = "-extension layouts_beta"; { expect; } diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml b/testsuite/tests/typing-layouts-products/typing_warnings_unboxed_records.ml similarity index 98% rename from testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml rename to testsuite/tests/typing-layouts-products/typing_warnings_unboxed_records.ml index b56729eeaed..c6f3d3d2340 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml +++ b/testsuite/tests/typing-layouts-products/typing_warnings_unboxed_records.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w +A -strict-sequence -extension layouts_beta"; + flags = " -w +A -strict-sequence"; expect; *) @@ -32,10 +32,7 @@ external ignore_product : ('a : value & value). 'a -> unit = "%ignore" |}] (* This below tests are adapted from - [testsuite/tests/typing-warnings/records.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) + [testsuite/tests/typing-warnings/records.ml]. *) (* Use type information *) module M1 = struct diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml b/testsuite/tests/typing-layouts-products/unboxed_records.ml similarity index 97% rename from testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml rename to testsuite/tests/typing-layouts-products/unboxed_records.ml index 882c107a389..927e1b74603 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml +++ b/testsuite/tests/typing-layouts-products/unboxed_records.ml @@ -3,19 +3,6 @@ include stdlib_upstream_compatible; flambda2; { - ocamlc_byte_exit_status = "2"; - setup-ocamlc.byte-build-env; - compiler_reference = "${test_source_directory}/unboxed_records_stable.compilers.reference"; - ocamlc.byte; - check-ocamlc.byte-output; - }{ - ocamlc_byte_exit_status = "2"; - setup-ocamlc.byte-build-env; - flags = "-extension-universe upstream_compatible"; - compiler_reference = "${test_source_directory}/unboxed_records_stable.compilers.reference"; - ocamlc.byte; - check-ocamlc.byte-output; - }{ ocamlc_byte_exit_status = "2"; setup-ocamlc.byte-build-env; flags = "-extension-universe no_extensions"; @@ -46,7 +33,13 @@ }{ flags = "-extension layouts_beta"; bytecode; - } + }{ + flags = ""; + bytecode; + }{ + flags = ""; + native; + } *) open Stdlib_upstream_compatible diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference b/testsuite/tests/typing-layouts-products/unboxed_records.reference similarity index 100% rename from testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference rename to testsuite/tests/typing-layouts-products/unboxed_records.reference diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml b/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml similarity index 96% rename from testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml rename to testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml index af39bb18f64..8abb07c6569 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml @@ -42,10 +42,7 @@ Error: (******************************************************************************) (* The below is adapted from - [testsuite/tests/typing-layouts-products/basics_alpha.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) + [testsuite/tests/typing-layouts-products/basics_alpha.ml]. *) (* [t3] is allowed for unboxed tuples, and disallowed for (un)boxed records *) type t1 : any mod non_null diff --git a/testsuite/tests/typing-layouts-products/unboxed_records_disabled.compilers.reference b/testsuite/tests/typing-layouts-products/unboxed_records_disabled.compilers.reference new file mode 100644 index 00000000000..41eb03e2334 --- /dev/null +++ b/testsuite/tests/typing-layouts-products/unboxed_records_disabled.compilers.reference @@ -0,0 +1,4 @@ +File "unboxed_records.ml", line 47, characters 0-34: +47 | type ints = #{ x : int ; y : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This construct requires the stable version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference b/testsuite/tests/typing-layouts-products/unboxed_records_stable.compilers.reference similarity index 100% rename from testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference rename to testsuite/tests/typing-layouts-products/unboxed_records_stable.compilers.reference diff --git a/testsuite/tests/typing-layouts-unboxed-records/unique.ml b/testsuite/tests/typing-layouts-products/unique.ml similarity index 96% rename from testsuite/tests/typing-layouts-unboxed-records/unique.ml rename to testsuite/tests/typing-layouts-products/unique.ml index e9d1845bcb4..c7ce98a42bd 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unique.ml +++ b/testsuite/tests/typing-layouts-products/unique.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha -extension unique"; + flags = "-extension unique"; { expect; } @@ -15,7 +15,7 @@ let unique_use2 : ('a : value & value) @ unique -> unit = fun _ -> () type t = #{ x : string ; y : string } let mk : unit -> t @ unique = fun () -> #{ x = "hi"; y = "hi" } [%%expect{| -val unique_use : ('a : value_or_null). 'a @ unique -> unit = +val unique_use : 'a @ unique -> unit = val unique_use2 : ('a : value & value). 'a @ unique -> unit = type t = #{ x : string; y : string; } val mk : unit -> t @ unique = diff --git a/testsuite/tests/typing-layouts-unboxed-records/unused.ml b/testsuite/tests/typing-layouts-products/unused_unboxed_records.ml similarity index 93% rename from testsuite/tests/typing-layouts-unboxed-records/unused.ml rename to testsuite/tests/typing-layouts-products/unused_unboxed_records.ml index c9f53e69ea9..2f7ef566385 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unused.ml +++ b/testsuite/tests/typing-layouts-products/unused_unboxed_records.ml @@ -1,12 +1,9 @@ (* TEST - flags = " -w +A -strict-sequence -extension layouts_beta"; + flags = " -w +A -strict-sequence"; expect; *) -(* Adapted from [testsuite/tests/typing-warnings/unused_types.ml]. - - CR layouts v7.2: Once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) +(* Adapted from [testsuite/tests/typing-warnings/unused_types.ml]. *) module Unused_record : sig end = struct type t = #{ a : int; b : int } diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml deleted file mode 100644 index 34c7c5731d3..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* TEST - flags = "-extension layouts_beta"; - expect; -*) -(* This test is adapted from - [testsuite/tests/typing-unboxed-types/test.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) - -(* Check the unboxing *) - -(* For records *) -type t2 = #{ f : string } ;; -[%%expect{| -type t2 = #{ f : string; } -|}];; - -let x = #{ f = "foo" } in -Obj.repr x == Obj.repr x.#f -;; -[%%expect{| -- : bool = true -|}];; - -(* Representation mismatch between module and signature must be rejected *) -module M : sig - type t = { a : string } -end = struct - type t = #{ a : string } -end;; -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = #{ a : string } -5 | end.. -Error: Signature mismatch: - Modules do not match: - sig type t = #{ a : string; } end - is not included in - sig type t = { a : string; } end - Type declarations do not match: - type t = #{ a : string; } - is not included in - type t = { a : string; } - The first is an unboxed record, but the second is a record. -|}];; - -module M : sig - type t = #{ a : string } -end = struct - type t = { a : string } -end;; -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = { a : string } -5 | end.. -Error: Signature mismatch: - Modules do not match: - sig type t = { a : string; } end - is not included in - sig type t = #{ a : string; } end - Type declarations do not match: - type t = { a : string; } - is not included in - type t = #{ a : string; } - The first is a record, but the second is an unboxed record. -|}] - -(* Check interference with representation of float arrays. *) -type t11 = #{ f : float };; -[%%expect{| -type t11 = #{ f : float; } -|}];; -let x = Array.make 10 #{ f = 3.14 } (* represented as a flat array *) -and f (a : t11 array) = a.(0) (* might wrongly assume an array of pointers *) -in assert (f x = #{ f = 3.14});; -[%%expect{| -- : unit = () -|}];; - -(* Check for a potential infinite loop in the typing algorithm. *) -type 'a t12 : value = #{ a : 'a t12 };; -[%%expect{| -type 'a t12 = #{ a : 'a t12; } -|}];; -let f (a : int t12 array) = a.(0);; -[%%expect{| -val f : int t12 array -> int t12 = -|}];; - -(* should work *) -type t14;; -type t15 = #{ a : t14 };; -[%%expect{| -type t14 -type t15 = #{ a : t14; } -|}];; - -(* should fail because the compiler knows that t is actually float and - optimizes the record's representation *) -module S : sig - type t - type u = { f1 : t; f2 : t } -end = struct - type t = #{ a : float } - type u = { f1 : t; f2 : t } -end;; -[%%expect{| -Lines 4-7, characters 6-3: -4 | ......struct -5 | type t = #{ a : float } -6 | type u = { f1 : t; f2 : t } -7 | end.. -Error: Signature mismatch: - Modules do not match: - sig type t = #{ a : float; } type u = { f1 : t; f2 : t; } end - is not included in - sig type t type u = { f1 : t; f2 : t; } end - Type declarations do not match: - type u = { f1 : t; f2 : t; } - is not included in - type u = { f1 : t; f2 : t; } - Their internal representations differ: - the first declaration uses unboxed float representation. -|}];; - -(* implementing [@@immediate] with unboxed records: this works because the - representation of [t] is [int] - *) -module T : sig - type t [@@immediate] -end = struct - type t = #{ i : int } -end;; -[%%expect{| -module T : sig type t : immediate end -|}];; - - -(* MPR#7682 *) -type f = #{field: 'a. 'a list} ;; -let g = Array.make 10 #{ field=[] };; -let h = g.(5);; -[%%expect{| -type f = #{ field : 'a. 'a list; } -val g : f array = - [|#{field = []}; #{field = []}; #{field = []}; #{field = []}; - #{field = []}; #{field = []}; #{field = []}; #{field = []}; - #{field = []}; #{field = []}|] -val h : f = #{field = []} -|}];; diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml deleted file mode 100644 index f48ce4c38d0..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml +++ /dev/null @@ -1,1017 +0,0 @@ -(* TEST - flambda2; - include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; - { - expect; - } -*) - -(* These tests are adapted from the tuple tests in - [testsuite/tests/typing-layouts-products/basics.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) - -open Stdlib_upstream_compatible - -(**********************************************************) -(* Test 1: Basic unboxed product layouts and record types. *) - -type t2 = #{ s : string; f : float#; i : int } -[%%expect{| -type t2 = #{ s : string; f : float#; i : int; } -|}] - -(* You can put unboxed and normal products inside unboxed products *) -type t4_inner2 = #{ b : bool; i : int } -type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option } -type t4 = #{ s : string; t4_inner : t4_inner } -[%%expect{| -type t4_inner2 = #{ b : bool; i : int; } -type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option; } -type t4 = #{ s : string; t4_inner : t4_inner; } -|}] - -(* But you can't put unboxed products into tuples (yet) *) -type t_nope_inner = #{ s : string; b : bool } -type t_nope = string * t_nope_inner -[%%expect{| -type t_nope_inner = #{ s : string; b : bool; } -Line 2, characters 23-35: -2 | type t_nope = string * t_nope_inner - ^^^^^^^^^^^^ -Error: Tuple element types must have layout value. - The layout of "t_nope_inner" is value & value - because of the definition of t_nope_inner at line 1, characters 0-45. - But the layout of "t_nope_inner" must be a sublayout of value - because it's the type of a tuple element. -|}] - -(********************************************) -(* Test 2: Simple kind annotations on types *) - -type t1 : float64 & value = #{ f : float#; b : bool } -type t2 : value & (float64 & value) = #{ so : string option ; t1 : t1 } -[%%expect{| -type t1 = #{ f : float#; b : bool; } -type t2 = #{ so : string option; t1 : t1; } -|}] - -type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } -[%%expect{| -Line 1, characters 0-74: -1 | type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The layout of type "t2_wrong" is value & (float64 & value) - because it is an unboxed record. - But the layout of type "t2_wrong" must be a sublayout of value & float64 & value - because of the annotation on the declaration of the type t2_wrong. -|}] - -type ('a : value & bits64) t3 = 'a -type t4_inner = #{ i : int; i64 : int64# } -type t4 = t4_inner t3 -type t5 = t4 t3 -[%%expect{| -type ('a : value & bits64) t3 = 'a -type t4_inner = #{ i : int; i64 : int64#; } -type t4 = t4_inner t3 -type t5 = t4 t3 -|}] - -type t4_wrong_inner = #{ i1 : int; i2 : int } -type t4_wrong = t4_wrong_inner t3 -[%%expect{| -type t4_wrong_inner = #{ i1 : int; i2 : int; } -Line 2, characters 16-30: -2 | type t4_wrong = t4_wrong_inner t3 - ^^^^^^^^^^^^^^ -Error: This type "t4_wrong_inner" should be an instance of type - "('a : value & bits64)" - The layout of t4_wrong_inner is value & value - because of the definition of t4_wrong_inner at line 1, characters 0-45. - But the layout of t4_wrong_inner must be a sublayout of value & bits64 - because of the definition of t3 at line 1, characters 0-34. -|}] - -(* some mutually recusive types *) -type ('a : value & bits64) t6 = 'a t7 -and 'a t7 = { x : 'a t6 } -[%%expect{| -type ('a : value & bits64) t6 = 'a t7 -and ('a : value & bits64) t7 = { x : 'a t6; } -|}] - -type t9_record = #{ i : int; i64 : int64# } -type t9 = t9_record t7 -type t10 = bool t6 -[%%expect{| -type t9_record = #{ i : int; i64 : int64#; } -type t9 = t9_record t7 -Line 3, characters 11-15: -3 | type t10 = bool t6 - ^^^^ -Error: This type "bool" should be an instance of type "('a : value & bits64)" - The layout of bool is value - because it is the primitive type bool. - But the layout of bool must be a sublayout of value & bits64 - because of the definition of t6 at line 1, characters 0-37. -|}] - -(* CR layouts v7.2: The below has a very bad error message. *) -type t6_wrong_inner_record = #{ i : int; i64 : int64 } -and ('a : value & bits64) t6_wrong = 'a t7_wrong -and 'a t7_wrong = { x : t6_wrong_inner_record t6_wrong } -[%%expect{| -Line 1, characters 0-54: -1 | type t6_wrong_inner_record = #{ i : int; i64 : int64 } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of t6_wrong_inner_record is any & any - because it is an unboxed record. - But the layout of t6_wrong_inner_record must be a sublayout of - value & bits64 - because of the annotation on 'a in the declaration of the type - t6_wrong. -|}] - -(* Just like t6/t7, but with the annotation on the other (the order doesn't - matter) *) -type 'a t11 = 'a t12 -and ('a : value & bits64) t12 = { x : 'a t11 } -[%%expect{| -type ('a : value & bits64) t11 = 'a t12 -and ('a : value & bits64) t12 = { x : 'a t11; } -|}] - -(*********************************************************************) -(* Test 3: Unboxed records are allowed in function args and returns *) - -type t1_left = #{ i : int; b : bool } -type t1_right_inner = #{ i64 : int64#; so : string option } -type t1_right = #{ i : int; f : float#; inner : t1_right_inner } -type t1 = t1_left -> t1_right -[%%expect{| -type t1_left = #{ i : int; b : bool; } -type t1_right_inner = #{ i64 : int64#; so : string option; } -type t1_right = #{ i : int; f : float#; inner : t1_right_inner; } -type t1 = t1_left -> t1_right -|}] - -type make_record_result = #{ f : float#; s : string } -let f_make_an_unboxed_record (x : string) (y : float#) = #{ f = y; s = x } - -type inner = #{ f1 : float#; f2 : float# } -type t = #{ s : string; inner : inner } -let f_pull_apart_an_unboxed_record (x : t) = - match x with - | #{ s; inner = #{ f1; f2 } } -> - if s = "mul" then - Float_u.mul f1 f2 - else - Float_u.add f1 f2 -[%%expect{| -type make_record_result = #{ f : float#; s : string; } -val f_make_an_unboxed_record : string -> float# -> make_record_result = -type inner = #{ f1 : float#; f2 : float#; } -type t = #{ s : string; inner : inner; } -val f_pull_apart_an_unboxed_record : - t -> Stdlib_upstream_compatible.Float_u.t = -|}] - - -module type S = sig - type a - type b - type c - type d - type e - type f - type g - type h -end - -module F(X : S) = struct - include X - type mix_input_inner2 = #{ d : d; e : e } - type mix_input_inner = #{ c : c; inner2 : mix_input_inner2 } - type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f } - type mix_output_inner2 = #{ f : f; e : e } - type mix_output_inner = #{ c : c; inner2 : mix_output_inner2 } - type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d } - let f_mix_up_an_unboxed_record (x : mix_input) = - let #{ a; b; inner = #{ c; inner2 = #{ d; e } }; f } = x in - #{ b = b; inner = #{ c = c; inner2 = #{ f = f; e = e } }; a = a; d = d } - - type take_few_input1 = #{ a : a; b : b } - type take_few_input3 = #{ d : d; e : e } - type take_few_input5 = #{ g : g; h : h } - type take_few_output = - #{ h : h; g2 : g; x4 : f; e2 : e; d : d; x2 : c; b : b; a2 : a } - - let f_take_a_few_unboxed_records (x1 : take_few_input1) x2 - (x3 : take_few_input3) x4 (x5 : take_few_input5) = - let #{ a; b } = x1 in - let #{ d; e } = x3 in - let #{ g; h } = x5 in - #{ h = h; g2 = g; x4 = x4; e2 = e; d = d; x2 = x2; b = b; a2 = a } -end -[%%expect{| -module type S = - sig type a type b type c type d type e type f type g type h end -module F : - functor (X : S) -> - sig - type a = X.a - type b = X.b - type c = X.c - type d = X.d - type e = X.e - type f = X.f - type g = X.g - type h = X.h - type mix_input_inner2 = #{ d : d; e : e; } - type mix_input_inner = #{ c : c; inner2 : mix_input_inner2; } - type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f; } - type mix_output_inner2 = #{ f : f; e : e; } - type mix_output_inner = #{ c : c; inner2 : mix_output_inner2; } - type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d; } - val f_mix_up_an_unboxed_record : mix_input -> mix_output - type take_few_input1 = #{ a : a; b : b; } - type take_few_input3 = #{ d : d; e : e; } - type take_few_input5 = #{ g : g; h : h; } - type take_few_output = #{ - h : h; - g2 : g; - x4 : f; - e2 : e; - d : d; - x2 : c; - b : b; - a2 : a; - } - val f_take_a_few_unboxed_records : - take_few_input1 -> - c -> take_few_input3 -> f -> take_few_input5 -> take_few_output - end -|}] - -(***************************************************) -(* Test 4: Unboxed products don't go in structures *) - -type poly_var_inner = #{ i : int; b : bool } -type poly_var_type = [ `Foo of poly_var_inner ] -[%%expect{| -type poly_var_inner = #{ i : int; b : bool; } -Line 2, characters 31-45: -2 | type poly_var_type = [ `Foo of poly_var_inner ] - ^^^^^^^^^^^^^^ -Error: Polymorphic variant constructor argument types must have layout value. - The layout of "poly_var_inner" is value & value - because of the definition of poly_var_inner at line 1, characters 0-44. - But the layout of "poly_var_inner" must be a sublayout of value - because it's the type of the field of a polymorphic variant. -|}] - -type poly_var_term_record = #{ i : int; i2 : int } -let poly_var_term = `Foo #{ i = 1; i2 = 2 } -[%%expect{| -type poly_var_term_record = #{ i : int; i2 : int; } -Line 2, characters 25-43: -2 | let poly_var_term = `Foo #{ i = 1; i2 = 2 } - ^^^^^^^^^^^^^^^^^^ -Error: This expression has type "poly_var_term_record" - but an expression was expected of type "('a : value_or_null)" - The layout of poly_var_term_record is value & value - because of the definition of poly_var_term_record at line 1, characters 0-50. - But the layout of poly_var_term_record must be a sublayout of value - because it's the type of the field of a polymorphic variant. -|}] - -type record_inner = #{ b : bool; f : float# } -type tuple_type = (int * record_inner) -[%%expect{| -type record_inner = #{ b : bool; f : float#; } -Line 2, characters 25-37: -2 | type tuple_type = (int * record_inner) - ^^^^^^^^^^^^ -Error: Tuple element types must have layout value. - The layout of "record_inner" is value & float64 - because of the definition of record_inner at line 1, characters 0-45. - But the layout of "record_inner" must be a sublayout of value - because it's the type of a tuple element. -|}] - -type record = #{ i : int; i2 : int } -let tuple_term = ("hi", #{ i = 1; i2 = 2 }) -[%%expect{| -type record = #{ i : int; i2 : int; } -Line 2, characters 24-42: -2 | let tuple_term = ("hi", #{ i = 1; i2 = 2 }) - ^^^^^^^^^^^^^^^^^^ -Error: This expression has type "record" but an expression was expected of type - "('a : value_or_null)" - The layout of record is value & value - because of the definition of record at line 1, characters 0-36. - But the layout of record must be a sublayout of value - because it's the type of a tuple element. -|}] - -type record_inner = #{ i : int; b : bool } -type record = { x : record_inner } -[%%expect{| -type record_inner = #{ i : int; b : bool; } -Line 2, characters 0-34: -2 | type record = { x : record_inner } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "record_inner" has layout "value & value". - Records may not yet contain types of this layout. -|}] - -type inlined_inner = #{ i : int; b : bool } -type inlined_record = A of { x : inlined_inner } -[%%expect{| -type inlined_inner = #{ i : int; b : bool; } -Line 2, characters 22-48: -2 | type inlined_record = A of { x : inlined_inner } - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "inlined_inner" has layout "value & value". - Inlined records may not yet contain types of this layout. -|}] - -type variant_inner = #{ i : int; b : bool } -type variant = A of variant_inner -[%%expect{| -type variant_inner = #{ i : int; b : bool; } -Line 2, characters 15-33: -2 | type variant = A of variant_inner - ^^^^^^^^^^^^^^^^^^ -Error: Type "variant_inner" has layout "value & value". - Variants may not yet contain types of this layout. -|}] - -type sig_inner = #{ i : int; b : bool } -module type S = sig - val x : sig_inner -end -[%%expect{| -type sig_inner = #{ i : int; b : bool; } -Line 3, characters 10-19: -3 | val x : sig_inner - ^^^^^^^^^ -Error: This type signature for "x" is not a value type. - The layout of type sig_inner is value & value - because of the definition of sig_inner at line 1, characters 0-39. - But the layout of type sig_inner must be a sublayout of value - because it's the type of something stored in a module structure. -|}] - -type m_record = #{ i1 : int; i2 : int } -module M = struct - let x = #{ i1 = 1; i2 = 2 } -end -[%%expect{| -type m_record = #{ i1 : int; i2 : int; } -Line 3, characters 6-7: -3 | let x = #{ i1 = 1; i2 = 2 } - ^ -Error: Types of top-level module bindings must have layout "value", but - the type of "x" has layout "value & value". -|}] - -type object_inner = #{ i : int; b : bool } -type object_type = < x : object_inner > -[%%expect{| -type object_inner = #{ i : int; b : bool; } -Line 2, characters 21-37: -2 | type object_type = < x : object_inner > - ^^^^^^^^^^^^^^^^ -Error: Object field types must have layout value. - The layout of "object_inner" is value & value - because of the definition of object_inner at line 1, characters 0-42. - But the layout of "object_inner" must be a sublayout of value - because it's the type of an object field. -|}] - -type object_term_record = #{ i1 : int; i2 : int } -let object_term = object val x = #{ i1 = 1; i2 = 2 } end -[%%expect{| -type object_term_record = #{ i1 : int; i2 : int; } -Line 2, characters 29-30: -2 | let object_term = object val x = #{ i1 = 1; i2 = 2 } end - ^ -Error: Variables bound in a class must have layout value. - The layout of x is value & value - because of the definition of object_term_record at line 1, characters 0-49. - But the layout of x must be a sublayout of value - because it's the type of a class field. -|}] - -type class_record = #{ i1 : int; i2 : int } -class class_ = - object - method x = #{ i1 = 1; i2 = 2 } - end -[%%expect{| -type class_record = #{ i1 : int; i2 : int; } -Line 4, characters 15-34: -4 | method x = #{ i1 = 1; i2 = 2 } - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "class_record" - but an expression was expected of type "('a : value)" - The layout of class_record is value & value - because of the definition of class_record at line 1, characters 0-43. - But the layout of class_record must be a sublayout of value - because it's the type of an object field. -|}] - -type capture_record = #{ x : int; y : int } -let capture_in_object utup = object - val f = fun () -> - let #{ x; y } = utup in - x + y -end;; -[%%expect{| -type capture_record = #{ x : int; y : int; } -Line 4, characters 20-24: -4 | let #{ x; y } = utup in - ^^^^ -Error: This expression has type "('a : value_or_null)" - but an expression was expected of type "capture_record" - The layout of capture_record is value & value - because of the definition of capture_record at line 1, characters 0-43. - But the layout of capture_record must be a sublayout of value - because it's the type of a variable captured in an object. -|}];; - -(****************************************************) -(* Test 5: Methods may take/return unboxed products *) - -type method_input = #{ a : int; b : int } -type method_output = #{ sum_a : int; sum_b : int } - -class class_with_urecord_manipulating_method = - object - method f (x : method_input) (y : method_input) = - let #{ a; b } = x in - let #{ a = c; b = d } = y in - #{ sum_a = a + c; sum_b = b + d } - end -[%%expect{| -type method_input = #{ a : int; b : int; } -type method_output = #{ sum_a : int; sum_b : int; } -class class_with_urecord_manipulating_method : - object method f : method_input -> method_input -> method_output end -|}] - -(*******************************************) -(* Test 6: Nested expansion in kind checks *) - -(* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and - boxed records, in the same way as below. - - CR layouts v7.2: These should typecheck for all record forms. -*) -module type S_coherence_deep = sig - type t1 : any - type t2 = #{ i : int; t1 : t1 } -end -[%%expect{| -Line 3, characters 24-31: -3 | type t2 = #{ i : int; t1 : t1 } - ^^^^^^^ -Error: Unboxed record element types must have a representable layout. - The layout of t1 is any - because of the definition of t1 at line 2, characters 2-15. - But the layout of t1 must be representable - because it is the type of record field t1. -|}] - -module type S_coherence_deep = sig - type t1 : any - type t2 = { t1 : t1 } [@@unboxed] -end -[%%expect{| -Line 3, characters 14-21: -3 | type t2 = { t1 : t1 } [@@unboxed] - ^^^^^^^ -Error: [@@unboxed] record element types must have a representable layout. - The layout of t1/2 is any - because of the definition of t1 at line 2, characters 2-15. - But the layout of t1/2 must be representable - because it is the type of record field t1. -|}] - -(***********************************************) -(* Test 7: modal kinds for unboxed record types *) - -type local_cross1 = #{ i1 : int; i2 : int } -let f_external_urecord_mode_crosses_local_1 - : local_ local_cross1 -> local_cross1 = fun x -> x -[%%expect{| -type local_cross1 = #{ i1 : int; i2 : int; } -val f_external_urecord_mode_crosses_local_1 : - local_ local_cross1 -> local_cross1 = -|}] - -type local_nocross1 = #{ i : int; s : string } -let f_internal_urecord_does_not_mode_cross_local_1 - : local_ local_nocross1 -> local_nocross1 = fun x -> x -[%%expect{| -type local_nocross1 = #{ i : int; s : string; } -Line 3, characters 55-56: -3 | : local_ local_nocross1 -> local_nocross1 = fun x -> x - ^ -Error: This value escapes its region. -|}] - -type local_cross2_inner = #{ b : bool; i : int } -type local_cross2 = #{ i : int; inner : local_cross2_inner } -let f_external_urecord_mode_crosses_local_2 - : local_ local_cross2 -> local_cross2 = fun x -> x -[%%expect{| -type local_cross2_inner = #{ b : bool; i : int; } -type local_cross2 = #{ i : int; inner : local_cross2_inner; } -val f_external_urecord_mode_crosses_local_2 : - local_ local_cross2 -> local_cross2 = -|}] - -type local_nocross2_inner = #{ b : bool; s : string } -type local_nocross2 = #{ i : int; inner : local_nocross2_inner } -let f_internal_urecord_does_not_mode_cross_local_2 - : local_ local_nocross2 -> local_nocross2 = fun x -> x -[%%expect{| -type local_nocross2_inner = #{ b : bool; s : string; } -type local_nocross2 = #{ i : int; inner : local_nocross2_inner; } -Line 4, characters 55-56: -4 | : local_ local_nocross2 -> local_nocross2 = fun x -> x - ^ -Error: This value escapes its region. -|}] - -type t = #{ i1 : int; i2 : int } -type local_cross3_inner = #{ t : t; i : int } -type local_cross3 = #{ i : int; inner : local_cross3_inner } -let f_external_urecord_mode_crosses_local_3 - : local_ local_cross3 -> local_cross3 = fun x -> x -[%%expect{| -type t = #{ i1 : int; i2 : int; } -type local_cross3_inner = #{ t : t; i : int; } -type local_cross3 = #{ i : int; inner : local_cross3_inner; } -val f_external_urecord_mode_crosses_local_3 : - local_ local_cross3 -> local_cross3 = -|}] - -type t = #{ s : string; i : int } -type local_nocross3_inner = #{ t : t; b : bool } -type local_nocross3 = #{ i : int; inner : local_nocross3_inner } -let f_internal_urecord_does_not_mode_cross_local_3 - : local_ local_nocross3 -> local_nocross3 = fun x -> x -[%%expect{| -type t = #{ s : string; i : int; } -type local_nocross3_inner = #{ t : t; b : bool; } -type local_nocross3 = #{ i : int; inner : local_nocross3_inner; } -Line 5, characters 55-56: -5 | : local_ local_nocross3 -> local_nocross3 = fun x -> x - ^ -Error: This value escapes its region. -|}] - -(****************************************************) -(* Test 8: modal kinds for product kind annotations *) - -(* Nothing unique to unboxed records here *) - -(*********************) -(* Test 9: externals *) - -type t_product : value & value - -type ext_record_arg_record = #{ i : int; b : bool } -external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" -[%%expect{| -type t_product : value & value -type ext_record_arg_record = #{ i : int; b : bool; } -Line 4, characters 26-54: -4 | external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -type ext_record_arg_attr_record = #{ i : int; b : bool } -external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" -[%%expect{| -type ext_record_arg_attr_record = #{ i : int; b : bool; } -Line 2, characters 37-63: -2 | external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -external ext_product_arg : t_product -> int = "foo" "bar" -[%%expect{| -Line 1, characters 27-43: -1 | external ext_product_arg : t_product -> int = "foo" "bar" - ^^^^^^^^^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" -[%%expect{| -Line 1, characters 38-47: -1 | external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" - ^^^^^^^^^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -type t = #{ i : int; b : bool } -external ext_record_return : int -> t = "foo" "bar" -[%%expect{| -type t = #{ i : int; b : bool; } -Line 2, characters 29-37: -2 | external ext_record_return : int -> t = "foo" "bar" - ^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -type t = #{ i : int; b : bool } -external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" -[%%expect{| -type t = #{ i : int; b : bool; } -Line 2, characters 47-48: -2 | external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" - ^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -external ext_product_return : int -> t_product = "foo" "bar" -[%%expect{| -Line 1, characters 30-46: -1 | external ext_product_return : int -> t_product = "foo" "bar" - ^^^^^^^^^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" -[%%expect{| -Line 1, characters 48-57: -1 | external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" - ^^^^^^^^^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -external[@layout_poly] id : ('a : any). 'a -> 'a = "%identity" - -type id_record = #{ x : int; y : int } -let sum = - let #{ x; y } = id #{ x = 1; y = 2 } in - x + y -[%%expect{| -external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] -type id_record = #{ x : int; y : int; } -val sum : int = 3 -|}] - -(***********************************) -(* Test 9: not allowed in let recs *) - -(* An example that is allowed on tuples but not unboxed products *) -let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () - -type letrec_record = #{ i1 : int; i2 : int } -let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () -[%%expect{| -val e1 : unit = () -type letrec_record = #{ i1 : int; i2 : int; } -Line 4, characters 37-56: -4 | let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "letrec_record" - but an expression was expected of type "('a : value_or_null)" - The layout of letrec_record is value & value - because of the definition of letrec_record at line 3, characters 0-44. - But the layout of letrec_record must be a sublayout of value - because it's the type of the recursive variable x. -|}] - -(* Unboxed records of kind value are also disallowed: *) -type letrec_record = #{ i : int } -let e2 = let rec x = #{ i = y } and y = 42 in () -[%%expect{| -type letrec_record = #{ i : int; } -Line 2, characters 21-31: -2 | let e2 = let rec x = #{ i = y } and y = 42 in () - ^^^^^^^^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" -|}] - -(* This example motivates having a check in [type_let], because - [Value_rec_check] is not set up to reject it, but we don't support even this - limited form of unboxed let rec (yet). *) -type letrec_simple = #{ i1 : int; i2 : int } -let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 -[%%expect{| -type letrec_simple = #{ i1 : int; i2 : int; } -Line 2, characters 21-41: -2 | let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 - ^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "letrec_simple" - but an expression was expected of type "('a : value_or_null)" - The layout of letrec_simple is value & value - because of the definition of letrec_simple at line 1, characters 0-44. - But the layout of letrec_simple must be a sublayout of value - because it's the type of the recursive variable _x. -|}] - -(**********************************************************) -(* Test 10: unboxed products not allowed in [@@unboxed] declarations (yet) *) - -type unboxed_record = #{ i1 : int; i2 : int } -type t = A of unboxed_record [@@unboxed] -[%%expect{| -type unboxed_record = #{ i1 : int; i2 : int; } -Line 2, characters 9-28: -2 | type t = A of unboxed_record [@@unboxed] - ^^^^^^^^^^^^^^^^^^^ -Error: Type "unboxed_record" has layout "value & value". - Unboxed variants may not yet contain types of this layout. -|}] - -type ('a : value & value) t = A of { x : 'a } [@@unboxed] -[%%expect{| -Line 1, characters 37-43: -1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] - ^^^^^^ -Error: Type "'a" has layout "value & value". - [@@unboxed] inlined records may not yet contain types of this layout. -|}] - -type unboxed_inline_record = #{ i1 : int; i2 : int } -type t = A of { x : unboxed_inline_record } [@@unboxed] -[%%expect{| -type unboxed_inline_record = #{ i1 : int; i2 : int; } -Line 2, characters 16-41: -2 | type t = A of { x : unboxed_inline_record } [@@unboxed] - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "unboxed_inline_record" has layout "value & value". - [@@unboxed] inlined records may not yet contain types of this layout. -|}] - -(* Unboxed records of kind value are allowed *) - -type unboxed_record = #{ i : int } -type t = A of unboxed_record [@@unboxed] -[%%expect{| -type unboxed_record = #{ i : int; } -type t = A of unboxed_record [@@unboxed] -|}] - -type t = A of { x : unboxed_record } [@@unboxed] -[%%expect{| -type t = A of { x : unboxed_record; } [@@unboxed] -|}] - - -(**************************************) -(* Test 11: Unboxed records and arrays *) - -(* You can write the type of an array of unboxed records, but not create - one. Soon, you can do both. *) -type ('a : value & value) t1 = 'a array -type ('a : bits64 & (value & float64)) t2 = 'a array - -type t3_record = #{ i : int; b : bool } -type t3 = t3_record array - -type t4_inner = #{ f : float#; bo : bool option } -type t4_record = #{ s : string; inner : t4_inner } -type t4 = t4_record array -[%%expect{| -type ('a : value & value) t1 = 'a array -type ('a : bits64 & (value & float64)) t2 = 'a array -type t3_record = #{ i : int; b : bool; } -type t3 = t3_record array -type t4_inner = #{ f : float#; bo : bool option; } -type t4_record = #{ s : string; inner : t4_inner; } -type t4 = t4_record array -|}] - -type array_record = #{ i1 : int; i2 : int } -let _ = [| #{ i1 = 1; i2 = 2 } |] -[%%expect{| -type array_record = #{ i1 : int; i2 : int; } -Line 2, characters 8-33: -2 | let _ = [| #{ i1 = 1; i2 = 2 } |] - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type array_record, - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. -|}] - -type array_init_record = #{ i1 : int; i2 : int } -let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) -[%%expect{| -type array_init_record = #{ i1 : int; i2 : int; } -Line 2, characters 31-50: -2 | let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "array_init_record" - but an expression was expected of type "('a : value)" - The layout of array_init_record is value & value - because of the definition of array_init_record at line 1, characters 0-48. - But the layout of array_init_record must be a sublayout of value. -|}] - -(* Arrays of unboxed records of kind value *are* allowed *) -type array_record = #{ i : int } -let _ = [| #{ i = 1 } |] -[%%expect{| -type array_record = #{ i : int; } -- : array_record array = [|#{i = 1}|] -|}] - -let _ = Array.init 3 (fun i -> #{ i }) -[%%expect{| -- : array_record array = [|#{i = 0}; #{i = 1}; #{i = 2}|] -|}] - -(***********************************************************) -(* Test 12: Unboxed products are not allowed as class args *) - -type class_arg_record = #{ a : int; b : int } -class product_instance_variable x = - let sum = let #{ a; b } = x in a + b in - object - method y = sum - end;; -[%%expect{| -type class_arg_record = #{ a : int; b : int; } -Line 3, characters 28-29: -3 | let sum = let #{ a; b } = x in a + b in - ^ -Error: This expression has type "('a : value)" - but an expression was expected of type "class_arg_record" - The layout of class_arg_record is value & value - because of the definition of class_arg_record at line 1, characters 0-45. - But the layout of class_arg_record must be a sublayout of value - because it's the type of a term-level argument to a class constructor. -|}] - -(* But unboxed records of kind value are: *) -type class_arg_record = #{ a : string } -class product_instance_variable x = - let s = let #{ a } = x in a in - object - method y = s - end;; -[%%expect{| -type class_arg_record = #{ a : string; } -class product_instance_variable : - class_arg_record -> object method y : string end -|}] - - -(*****************************************) -(* Test 13: No lazy unboxed products yet *) - -type lazy_record = #{ i1 : int; i2 : int } -let x = lazy #{ i1 = 1; i2 = 2 } -[%%expect{| -type lazy_record = #{ i1 : int; i2 : int; } -Line 2, characters 13-32: -2 | let x = lazy #{ i1 = 1; i2 = 2 } - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "lazy_record" - but an expression was expected of type "('a : value)" - The layout of lazy_record is value & value - because of the definition of lazy_record at line 1, characters 0-42. - But the layout of lazy_record must be a sublayout of value - because it's the type of a lazy expression. -|}] - -type lazy_t_record = #{ i1 : int; i2 : int } -type t = lazy_t_record lazy_t -[%%expect{| -type lazy_t_record = #{ i1 : int; i2 : int; } -Line 2, characters 9-22: -2 | type t = lazy_t_record lazy_t - ^^^^^^^^^^^^^ -Error: This type "lazy_t_record" should be an instance of type "('a : value)" - The layout of lazy_t_record is value & value - because of the definition of lazy_t_record at line 1, characters 0-44. - But the layout of lazy_t_record must be a sublayout of value - because the type argument of lazy_t has layout value. -|}] - -(* Again, unboxed records of kind value can be: *) - -type t = #{ i : int } -let x = lazy #{ i = 1 } -[%%expect{| -type t = #{ i : int; } -val x : t lazy_t = -|}] - -type t2 = t lazy_t -[%%expect{| -type t2 = t lazy_t -|}] - -(*********************************************) -(* Test 14: Unboxed records can't be coerced *) - -type t = private int - -type coerce_record = #{ t1 : t; t2 : t } -type coerce_int_record = #{ i1 : int; i2 : int } -let f (x : coerce_record) = - let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b -[%%expect{| -type t = private int -type coerce_record = #{ t1 : t; t2 : t; } -type coerce_int_record = #{ i1 : int; i2 : int; } -Line 6, characters 28-52: -6 | let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b - ^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "coerce_record" is not a subtype of "coerce_int_record" -|}] - -(************************************************) -(* Test 15: Not allowed as an optional argument *) - -type optional_record = #{ i1 : int; i2 : int } -let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x -[%%expect{| -type optional_record = #{ i1 : int; i2 : int; } -Line 2, characters 29-48: -2 | let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "optional_record" - but an expression was expected of type "('a : value)" - The layout of optional_record is value & value - because of the definition of optional_record at line 1, characters 0-46. - But the layout of optional_record must be a sublayout of value - because the type argument of option has layout value. -|}] - -(******************************) -(* Test 16: Decomposing [any] *) - -type ('a : value) u = U of 'a [@@unboxed] -type ('a : value) t = #{ u1 : 'a u; u2 : 'a u } - -type ('a : any mod global) needs_any_mod_global - -type should_work = int t needs_any_mod_global -[%%expect{| -type 'a u = U of 'a [@@unboxed] -type 'a t = #{ u1 : 'a u; u2 : 'a u; } -type ('a : any mod global) needs_any_mod_global -type should_work = int t needs_any_mod_global -|}] - -type should_fail = string t needs_any_mod_global -[%%expect{| -Line 1, characters 19-27: -1 | type should_fail = string t needs_any_mod_global - ^^^^^^^^ -Error: This type "string t" should be an instance of type "('a : any mod global)" - The kind of string t is value & value - because of the definition of t at line 2, characters 0-47. - But the kind of string t must be a subkind of any mod global - because of the definition of needs_any_mod_global at line 4, characters 0-47. -|}] - -type ('a : any mod external_) t - -type s_record = #{ i1 : int; s : string; i2 : int } -type s = s_record t -[%%expect{| -type ('a : any mod external_) t -type s_record = #{ i1 : int; s : string; i2 : int; } -Line 4, characters 9-17: -4 | type s = s_record t - ^^^^^^^^ -Error: This type "s_record" should be an instance of type - "('a : any mod external_)" - The kind of s_record is - immutable_data & immutable_data & immutable_data - because of the definition of s_record at line 3, characters 0-51. - But the kind of s_record must be a subkind of any mod external_ - because of the definition of t at line 1, characters 0-31. -|}] -(* CR layouts v7.1: Both the above have very bad error messages. *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/disabled.ml b/testsuite/tests/typing-layouts-unboxed-records/disabled.ml deleted file mode 100644 index 61ba712ee89..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/disabled.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* TEST - expect; -*) - -(* Types *) -type t = #{ a : int } -[%%expect{| -Line 1, characters 0-21: -1 | type t = #{ a : int } - ^^^^^^^^^^^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] - -(* Construction *) -let _ = #{ u = () } -[%%expect{| -Line 1, characters 8-19: -1 | let _ = #{ u = () } - ^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] - -(* Field *) -let get r = r.#x -[%%expect{| -Line 1, characters 12-16: -1 | let get r = r.#x - ^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] - -(* Patterns *) -let #{ u = () } = () -[%%expect{| -Line 1, characters 4-15: -1 | let #{ u = () } = () - ^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/exhaustiveness.ml b/testsuite/tests/typing-layouts-unboxed-records/exhaustiveness.ml deleted file mode 100644 index 55307a90abf..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/exhaustiveness.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* TEST - flags = "-w +8 -extension layouts_beta"; - expect; -*) - -(* This is a regression test. The example below used to give an exhaustiveness - warning because we forgot a case in [Parmatch.simple_match]. *) - -type t = A | B -type r = #{ x : t; y : t } - -let f t t' = - match #{ x = t; y = t' } with - | #{ x = A; y = _ } -> true - | #{ x = B; y = _ } -> false -[%%expect{| -type t = A | B -type r = #{ x : t; y : t; } -val f : t -> t -> bool = -|}] - -(* This is a regression test. The example below used to give - #{y=A; _ } as a counterexample instead of #{y=A; x=B}. *) -let g t t' = - match #{ x = t; y = t' } with - | #{ x = A; _ } -> true - | #{ y = B; _ } -> false -[%%expect{| -Lines 2-4, characters 2-26: -2 | ..match #{ x = t; y = t' } with -3 | | #{ x = A; _ } -> true -4 | | #{ y = B; _ } -> false -Warning 8 [partial-match]: this pattern-matching is not exhaustive. -Here is an example of a case that is not matched: -#{y=A; x=B} - -val g : t -> t -> bool = -|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/modality.ml b/testsuite/tests/typing-layouts-unboxed-records/modality.ml deleted file mode 100644 index c4d6e3bf8ca..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/modality.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* TEST - flags = "-extension layouts_beta"; - expect; -*) - -(* This test is adapted from - [testsuite/tests/typing-local/local.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) -type 'a gbl = #{ global_ gbl : 'a } -[%%expect{| -type 'a gbl = #{ global_ gbl : 'a; } -|}] - -let foo (local_ x) = x.#gbl -[%%expect{| -val foo : local_ 'a gbl -> 'a = -|}] -let foo y = - let x = local_ #{ gbl = y } in - x.#gbl -[%%expect{| -val foo : 'a -> 'a = -|}] -let foo (local_ #{ gbl }) = gbl -[%%expect{| -val foo : local_ 'a gbl -> 'a = -|}] -let foo y = - let #{ gbl } = local_ #{ gbl = y } in - gbl -[%%expect{| -val foo : 'a -> 'a = -|}] -let foo (local_ gbl) = - let _ = #{ gbl } in - () -[%%expect{| -Line 2, characters 13-16: -2 | let _ = #{ gbl } in - ^^^ -Error: This value escapes its region. -|}] -let foo () = - let gbl = local_ ref 5 in - let _ = #{ gbl } in - () -[%%expect{| -Line 3, characters 13-16: -3 | let _ = #{ gbl } in - ^^^ -Error: This value escapes its region. -|}] - -(* Global fields are preserved in module inclusion *) -module M : sig - type t = #{ global_ foo : string } -end = struct - type t = #{ foo : string } -end -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = #{ foo : string } -5 | end -Error: Signature mismatch: - Modules do not match: - sig type t = #{ foo : string; } end - is not included in - sig type t = #{ global_ foo : string; } end - Type declarations do not match: - type t = #{ foo : string; } - is not included in - type t = #{ global_ foo : string; } - Fields do not match: - "foo : string;" - is not the same as: - "global_ foo : string;" - The second is global_ and the first is not. -|}] - -module M : sig - type t = #{ foo : string } -end = struct - type t = #{ global_ foo : string } -end -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = #{ global_ foo : string } -5 | end -Error: Signature mismatch: - Modules do not match: - sig type t = #{ global_ foo : string; } end - is not included in - sig type t = #{ foo : string; } end - Type declarations do not match: - type t = #{ global_ foo : string; } - is not included in - type t = #{ foo : string; } - Fields do not match: - "global_ foo : string;" - is not the same as: - "foo : string;" - The first is global_ and the second is not. -|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference deleted file mode 100644 index 9c0cd4c1811..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference +++ /dev/null @@ -1,4 +0,0 @@ -File "parsing_inline_unboxed_record.ml", line 11, characters 22-24: -11 | type variant = Foo of #{ x : string } - ^^ -Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference deleted file mode 100644 index 11f6958ebe9..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference +++ /dev/null @@ -1,4 +0,0 @@ -File "parsing_module_dot_unboxed_record.ml", line 15, characters 11-12: -15 | let t = M.#{ i = 1 } - ^ -Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference deleted file mode 100644 index 75e6f993887..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference +++ /dev/null @@ -1,4 +0,0 @@ -File "unboxed_records.ml", line 54, characters 0-34: -54 | type ints = #{ x : int ; y : int } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml index f9957b277e8..bdbc9f5978f 100644 --- a/testsuite/tests/typing-local/local.ml +++ b/testsuite/tests/typing-local/local.ml @@ -1202,6 +1202,53 @@ Line 3, characters 12-15: Error: This value escapes its region. |}] +(* Unboxed records version of the same test *) + +type 'a gbl = #{ global_ gbl : 'a } +[%%expect{| +type 'a gbl = #{ global_ gbl : 'a; } +|}] + +let foo (local_ x) = x.#gbl +[%%expect{| +val foo : local_ 'a gbl -> 'a = +|}] +let foo y = + let x = local_ #{ gbl = y } in + x.#gbl +[%%expect{| +val foo : 'a -> 'a = +|}] +let foo (local_ #{ gbl }) = gbl +[%%expect{| +val foo : local_ 'a gbl -> 'a = +|}] +let foo y = + let #{ gbl } = local_ #{ gbl = y } in + gbl +[%%expect{| +val foo : 'a -> 'a = +|}] +let foo (local_ gbl) = + let _ = #{ gbl } in + () +[%%expect{| +Line 2, characters 13-16: +2 | let _ = #{ gbl } in + ^^^ +Error: This value escapes its region. +|}] +let foo () = + let gbl = local_ ref 5 in + let _ = #{ gbl } in + () +[%%expect{| +Line 3, characters 13-16: +3 | let _ = #{ gbl } in + ^^^ +Error: This value escapes its region. +|}] + (* Global fields are preserved in module inclusion *) module M : sig type t = { global_ foo : string } @@ -1255,6 +1302,60 @@ Error: Signature mismatch: The first is global_ and the second is not. |}] +(* Unboxed records version of the same test *) + +module M : sig + type t = #{ global_ foo : string } +end = struct + type t = #{ foo : string } +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ foo : string } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = #{ foo : string; } end + is not included in + sig type t = #{ global_ foo : string; } end + Type declarations do not match: + type t = #{ foo : string; } + is not included in + type t = #{ global_ foo : string; } + Fields do not match: + "foo : string;" + is not the same as: + "global_ foo : string;" + The second is global_ and the first is not. +|}] + +module M : sig + type t = #{ foo : string } +end = struct + type t = #{ global_ foo : string } +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ global_ foo : string } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = #{ global_ foo : string; } end + is not included in + sig type t = #{ foo : string; } end + Type declarations do not match: + type t = #{ global_ foo : string; } + is not included in + type t = #{ foo : string; } + Fields do not match: + "global_ foo : string;" + is not the same as: + "foo : string;" + The first is global_ and the second is not. +|}] + (* Special handling of tuples in matches and let bindings *) let escape : 'a -> unit = fun x -> () diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml index 9825f4fdfc3..a0d483357e2 100644 --- a/testsuite/tests/typing-unboxed-types/test.ml +++ b/testsuite/tests/typing-unboxed-types/test.ml @@ -34,6 +34,19 @@ Obj.repr x == Obj.repr x.f - : bool = true |}];; +(* For unboxed records *) +type t2 = #{ f : string } ;; +[%%expect{| +type t2 = #{ f : string; } +|}];; + +let x = #{ f = "foo" } in +Obj.repr x == Obj.repr x.#f +;; +[%%expect{| +- : bool = true +|}];; + (* For inline records *) type t3 = B of { g : string } [@@ocaml.unboxed];; [%%expect{| @@ -271,6 +284,50 @@ Error: Signature mismatch: the second declaration uses unboxed representation. |}];; +module M : sig + type t = { a : string } +end = struct + type t = #{ a : string } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ a : string } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = #{ a : string; } end + is not included in + sig type t = { a : string; } end + Type declarations do not match: + type t = #{ a : string; } + is not included in + type t = { a : string; } + The first is an unboxed record, but the second is a record. +|}];; + +module M : sig + type t = #{ a : string } +end = struct + type t = { a : string } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = { a : string } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = { a : string; } end + is not included in + sig type t = #{ a : string; } end + Type declarations do not match: + type t = { a : string; } + is not included in + type t = #{ a : string; } + The first is a record, but the second is an unboxed record. +|}] + (* Check interference with representation of float arrays. *) type t11 = L of float [@@ocaml.unboxed];; @@ -284,6 +341,17 @@ in assert (f x = L 3.14);; - : unit = () |}];; +type t11 = #{ f : float };; +[%%expect{| +type t11 = #{ f : float; } +|}];; +let x = Array.make 10 #{ f = 3.14 } (* represented as a flat array *) +and f (a : t11 array) = a.(0) (* might wrongly assume an array of pointers *) +in assert (f x = #{ f = 3.14});; +[%%expect{| +- : unit = () +|}];; + (* Check for a potential infinite loop in the typing algorithm. *) type 'a t12 = M of 'a t12 [@@ocaml.unboxed];; [%%expect{| @@ -294,6 +362,15 @@ let f (a : int t12 array) = a.(0);; val f : int t12 array -> int t12 = |}];; +type 'a t12 : value = #{ a : 'a t12 };; +[%%expect{| +type 'a t12 = #{ a : 'a t12; } +|}];; +let f (a : int t12 array) = a.(0);; +[%%expect{| +val f : int t12 array -> int t12 = +|}];; + (* Check for another possible loop *) type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];; [%%expect{| @@ -308,6 +385,12 @@ type t15 = A of t14 [@@ocaml.unboxed];; type t14 type t15 = A of t14 [@@unboxed] |}];; +type t14;; +type t15 = #{ a : t14 };; +[%%expect{| +type t14 +type t15 = #{ a : t14; } +|}];; (* should fail because the compiler knows that t is actually float and optimizes the record's representation *) @@ -337,6 +420,32 @@ Error: Signature mismatch: the first declaration uses unboxed float representation. |}];; +module S : sig + type t + type u = { f1 : t; f2 : t } +end = struct + type t = #{ a : float } + type u = { f1 : t; f2 : t } +end;; +[%%expect{| +Lines 4-7, characters 6-3: +4 | ......struct +5 | type t = #{ a : float } +6 | type u = { f1 : t; f2 : t } +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = #{ a : float; } type u = { f1 : t; f2 : t; } end + is not included in + sig type t type u = { f1 : t; f2 : t; } end + Type declarations do not match: + type u = { f1 : t; f2 : t; } + is not included in + type u = { f1 : t; f2 : t; } + Their internal representations differ: + the first declaration uses unboxed float representation. +|}];; + (* implementing [@@immediate] with [@@ocaml.unboxed]: this works because the representation of [t] is [int] *) @@ -349,6 +458,15 @@ end;; module T : sig type t : immediate end |}];; +module T : sig + type t [@@immediate] +end = struct + type t = #{ i : int } +end;; +[%%expect{| +module T : sig type t : immediate end +|}];; + (* Another corner case *) type 'a s type ('a, 'p) t = private 'a s @@ -372,6 +490,18 @@ val g : f array = val h : f = {field = []} |}];; +type f = #{field: 'a. 'a list} ;; +let g = Array.make 10 #{ field=[] };; +let h = g.(5);; +[%%expect{| +type f = #{ field : 'a. 'a list; } +val g : f array = + [|#{field = []}; #{field = []}; #{field = []}; #{field = []}; + #{field = []}; #{field = []}; #{field = []}; #{field = []}; + #{field = []}; #{field = []}|] +val h : f = #{field = []} +|}];; + (* Using [@@immediate] information (GPR#1469) *) type 'a t [@@immediate];; type u = U : 'a t -> u [@@unboxed];; diff --git a/typing/typecore.ml b/typing/typecore.ml index a028ef1bbcf..c45e7c72c10 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -3011,7 +3011,7 @@ and type_pat_aux | Ppat_record(lid_sp_list, closed) -> type_record_pat Legacy lid_sp_list closed | Ppat_record_unboxed_product(lid_sp_list, closed) -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_record_pat Unboxed_product lid_sp_list closed | Ppat_array (mut, spl) -> let mut = @@ -6003,7 +6003,7 @@ and type_expect_ | Pexp_record(lid_sexp_list, opt_sexp) -> type_expect_record ~overwrite Legacy lid_sexp_list opt_sexp | Pexp_record_unboxed_product(lid_sexp_list, opt_sexp) -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_expect_record ~overwrite Unboxed_product lid_sexp_list opt_sexp | Pexp_field(srecord, lid) -> let (record, rmode, label, _) = @@ -6055,7 +6055,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_unboxed_field(srecord, lid) -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; let (record, rmode, label, _) = type_label_access Unboxed_product env srecord Env.Projection lid in diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 30f24d1577f..c0d44b64740 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -933,7 +933,7 @@ let transl_declaration env sdecl (id, uid) = Ttype_record lbls, Type_record(lbls', rep), jkind | Ptype_record_unboxed_product lbls -> Language_extension.assert_enabled ~loc:sdecl.ptype_loc Layouts - Language_extension.Beta; + Language_extension.Stable; let lbls, lbls' = transl_labels ~record_form:Unboxed_product ~new_var_jkind:Any ~allow_unboxed:true env None true lbls Record_unboxed_product From 2de23a5caa97659358c45bf77560b79feb45046b Mon Sep 17 00:00:00 2001 From: Ryan Tjoa <51928404+rtjoa@users.noreply.github.com> Date: Mon, 6 Jan 2025 04:04:29 -0500 Subject: [PATCH 18/30] Fix CI by using `setup-ocaml` v3 for ocamlformat workflow (#3426) [CI] Use setup-ocaml v3 for ocamlformat workflow --- .github/workflows/ocamlformat.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ocamlformat.yml b/.github/workflows/ocamlformat.yml index 6436fb783b9..e4e2a479d95 100644 --- a/.github/workflows/ocamlformat.yml +++ b/.github/workflows/ocamlformat.yml @@ -21,7 +21,7 @@ jobs: path: 'flambda_backend' - name: Setup OCaml ${{ matrix.ocaml-compiler }} - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} From 2e49469d60363fb513ef0dee30f60f6da498e826 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Mon, 6 Jan 2025 13:05:03 -0500 Subject: [PATCH 19/30] Make Capsule preserve wrapped exception backtraces (#3421) * with_password * portable * don't use polymorphic parameters * review * protect encapsulated from other capsule * raise wrapped exceptions with existing backtrace * cr --- otherlibs/stdlib_alpha/capsule.ml | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/otherlibs/stdlib_alpha/capsule.ml b/otherlibs/stdlib_alpha/capsule.ml index 0bf66090e37..a760d466109 100644 --- a/otherlibs/stdlib_alpha/capsule.ml +++ b/otherlibs/stdlib_alpha/capsule.ml @@ -124,6 +124,8 @@ end (* Like [Stdlib.raise], but [portable], and the value it never returns is also [portable] *) external reraise : exn -> 'a @ portable @@ portable = "%reraise" +external raise_with_backtrace: exn -> Printexc.raw_backtrace -> 'a @ portable @@ portable = "%raise_with_backtrace" +external get_raw_backtrace: unit -> Printexc.raw_backtrace @@ portable = "caml_get_exception_raw_backtrace" module Data = struct type ('a, 'k) t : value mod portable uncontended @@ -142,11 +144,14 @@ module Data = struct let create f = unsafe_mk (f ()) + (* CR-soon mslater/tdelvecchio: copying the backtrace at each reraise can cause quadratic + behavior when propagating the exception through nested handlers. This should use a + new reraise-with-current-backtrace primitive that doesn't do the copy. *) let reraise_encapsulated password exn = - reraise (Encapsulated (Password.name password, unsafe_mk exn)) + raise_with_backtrace (Encapsulated (Password.name password, unsafe_mk exn)) (get_raw_backtrace ()) let reraise_encapsulated_shared password exn = - reraise (Encapsulated (Password.Shared.name password, unsafe_mk exn)) + raise_with_backtrace (Encapsulated (Password.Shared.name password, unsafe_mk exn)) (get_raw_backtrace ()) let map pw f t = let v = unsafe_get t in @@ -381,7 +386,11 @@ exception Protected : 'k Mutex.t * (exn, 'k) Data.t -> exn let protect_local f = exclave_ let (P name) = Name.make () in let password = Password.unsafe_mk name in - let reraise data = reraise (Protected ({ name; mutex = M.create (); poisoned = false }, data)) in + let reraise data = + let backtrace = get_raw_backtrace () in + let exn = (Protected ({ name; mutex = M.create (); poisoned = false }, data)) in + raise_with_backtrace exn backtrace + in try f (Password.P password) with | Encapsulated (inner, data) as exn -> (match Name.equality_witness name inner with From 00275e023ff412c54aa1e28cd4c436ce18857d03 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Mon, 6 Jan 2025 13:05:58 -0500 Subject: [PATCH 20/30] Unbox_float32 should check custom ops name (#3433) check sym name --- backend/cmm_helpers.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 3931e0eb7c6..5d2bbf94d65 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -802,9 +802,10 @@ let box_float32 dbg mode exp = let unbox_float32 dbg = map_tail ~kind:Any (function - | Cop (Calloc _, [Cconst_natint (hdr, _); _ops; c], _) - when Nativeint.equal hdr boxedfloat32_header - || Nativeint.equal hdr boxedfloat32_local_header -> + | Cop (Calloc _, [Cconst_natint (hdr, _); Cconst_symbol (sym, _); c], _) + when (Nativeint.equal hdr boxedfloat32_header + || Nativeint.equal hdr boxedfloat32_local_header) + && String.equal sym.sym_name caml_float32_ops -> c | Cconst_symbol (s, _dbg) as cmm -> ( match Cmmgen_state.structured_constant_of_sym s.sym_name with From 4a0bb698bef15d51e6d8c46473cb67db493d300e Mon Sep 17 00:00:00 2001 From: dkalinichenko-js <118547217+dkalinichenko-js@users.noreply.github.com> Date: Tue, 7 Jan 2025 15:34:27 -0500 Subject: [PATCH 21/30] `Yielding` mode axis (#3283) * `Yielding` mode axis * Tests * fix printing --------- Co-authored-by: Diana Kalinichenko --- ...test_locations.dlocations.ocamlc.reference | 8 +- ...t_locations.dno-locations.ocamlc.reference | 8 +- testsuite/tests/typing-layouts/jkinds.ml | 8 +- testsuite/tests/typing-modes/yielding.ml | 80 +++++++ typing/env.ml | 1 + typing/jkind.ml | 12 +- typing/jkind_axis.ml | 9 + typing/jkind_axis.mli | 2 + typing/mode.ml | 214 +++++++++++++----- typing/mode_intf.mli | 33 ++- typing/printtyp.ml | 3 +- typing/typecore.ml | 1 + typing/typemode.ml | 16 +- 13 files changed, 316 insertions(+), 79 deletions(-) create mode 100644 testsuite/tests/typing-modes/yielding.ml diff --git a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference index 7a75bc5e8d3..084fcdc96a5 100644 --- a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference @@ -89,13 +89,13 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11]) Tpat_var "fib" - value_mode global,many,nonportable;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) + value_mode global,many,nonportable,unyielding;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34]) Texp_function - alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended]) + alloc_mode global,many,nonportable,unyielding;id(modevar#7[aliased,contended .. unique,uncontended]) [] Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34]) - alloc_mode global,many,nonportable;aliased,uncontended + alloc_mode global,many,nonportable,unyielding;aliased,uncontended value [ @@ -110,7 +110,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern (test_locations.ml[19,572+4]..test_locations.ml[19,572+5]) Tpat_var "n" - value_mode global,many,portable;unique,uncontended + value_mode global,many,portable,unyielding;unique,uncontended expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+34]) Texp_apply apply_mode Tail diff --git a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference index 93910acca50..ea4b6f36a1e 100644 --- a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference @@ -89,13 +89,13 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern Tpat_var "fib" - value_mode global,many,nonportable;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) + value_mode global,many,nonportable,unyielding;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) expression Texp_function - alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended]) + alloc_mode global,many,nonportable,unyielding;id(modevar#7[aliased,contended .. unique,uncontended]) [] Tfunction_cases - alloc_mode global,many,nonportable;aliased,uncontended + alloc_mode global,many,nonportable,unyielding;aliased,uncontended value [ @@ -110,7 +110,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern Tpat_var "n" - value_mode global,many,portable;unique,uncontended + value_mode global,many,portable,unyielding;unique,uncontended expression Texp_apply apply_mode Tail diff --git a/testsuite/tests/typing-layouts/jkinds.ml b/testsuite/tests/typing-layouts/jkinds.ml index eec92625b42..119aab32b9b 100644 --- a/testsuite/tests/typing-layouts/jkinds.ml +++ b/testsuite/tests/typing-layouts/jkinds.ml @@ -279,8 +279,8 @@ Error: Layout void is more experimental than allowed by the enabled layouts exte |}] type a : immediate -type b : value mod global unique many uncontended portable external_ = a -type c : value mod global unique many uncontended portable external_ +type b : value mod global unique many uncontended portable unyielding external_ = a +type c : value mod global unique many uncontended portable unyielding external_ type d : immediate = c [%%expect{| type a : immediate @@ -290,8 +290,8 @@ type d = c |}] type a : immediate64 -type b : value mod global unique many uncontended portable external64 = a -type c : value mod global unique many uncontended portable external64 +type b : value mod global unique many uncontended portable unyielding external64 = a +type c : value mod global unique many uncontended portable unyielding external64 type d : immediate64 = c [%%expect{| type a : immediate64 diff --git a/testsuite/tests/typing-modes/yielding.ml b/testsuite/tests/typing-modes/yielding.ml new file mode 100644 index 00000000000..e472f807124 --- /dev/null +++ b/testsuite/tests/typing-modes/yielding.ml @@ -0,0 +1,80 @@ +(* TEST + expect; +*) + +(* CR dkalinichenko: allow [yielding] at toplevel? *) +let my_effect : unit -> unit @@ yielding = print_endline "Hello, world!" +[%%expect{| +Line 1, characters 4-72: +1 | let my_effect : unit -> unit @@ yielding = print_endline "Hello, world!" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This value is "yielding" but expected to be "unyielding". +|}] + +let storage = ref "" + +let with_effect : ((string -> unit) @ local yielding -> 'a) -> 'a = + fun f -> f ((:=) storage) + +[%%expect{| +val storage : string ref = {contents = ""} +val with_effect : (local_ (string -> unit) @ yielding -> 'a) -> 'a = +|}] + +let () = with_effect (fun k -> k "Hello, world!") + +let _ = !storage + +[%%expect{| +- : string = "Hello, world!" +|}] + +let run_yielding : (string -> unit) @ local yielding -> unit = fun f -> f "my string" + +let () = with_effect (fun k -> run_yielding k) + +let _ = !storage + +[%%expect{| +val run_yielding : local_ (string -> unit) @ yielding -> unit = +- : string = "my string" +|}] + +let run_unyielding : (string -> unit) @ local unyielding -> unit = fun f -> f "another string" + +let () = with_effect (fun k -> run_unyielding k) + +[%%expect{| +val run_unyielding : local_ (string -> unit) -> unit = +Line 3, characters 46-47: +3 | let () = with_effect (fun k -> run_unyielding k) + ^ +Error: This value is "yielding" but expected to be "unyielding". +|}] + +(* CR dkalinichenko: default [local] arguments to [yielding]. *) + +let run_default : (string -> unit) @ local -> unit = fun f -> f "some string" + +let () = with_effect (fun k -> run_default k) + +[%%expect{| +val run_default : local_ (string -> unit) -> unit = +Line 3, characters 43-44: +3 | let () = with_effect (fun k -> run_default k) + ^ +Error: This value is "yielding" but expected to be "unyielding". +|}] + +(* A closure over a [yielding] value must be [yielding]. *) + +let () = with_effect (fun k -> + let closure @ local unyielding = fun () -> k () in + run_unyielding k) + +[%%expect{| +Line 2, characters 45-46: +2 | let closure @ local unyielding = fun () -> k () in + ^ +Error: The value "k" is yielding, so cannot be used inside a function that may not yield. +|}] diff --git a/typing/env.ml b/typing/env.ml index ac7dba4540f..b89c70c4885 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -4419,6 +4419,7 @@ let report_lookup_error _loc env ppf = function | Error (Areality, _) -> "local", "might escape" | Error (Linearity, _) -> "once", "is many" | Error (Portability, _) -> "nonportable", "is portable" + | Error (Yielding, _) -> "yielding", "may not yield" in let s, hint = match context with diff --git a/typing/jkind.ml b/typing/jkind.ml index 27df68f136c..c0bb1512f4f 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -436,7 +436,8 @@ module Const = struct contention = Contention.Const.min; portability = Portability.Const.min; uniqueness = Uniqueness.Const.max; - areality = Locality.Const.max + areality = Locality.Const.max; + yielding = Yielding.Const.min }; externality_upper_bound = Externality.max; nullability_upper_bound = Nullability.Non_null @@ -452,7 +453,8 @@ module Const = struct contention = Contention.Const.max; portability = Portability.Const.min; uniqueness = Uniqueness.Const.max; - areality = Locality.Const.max + areality = Locality.Const.max; + yielding = Yielding.Const.min }; externality_upper_bound = Externality.max; nullability_upper_bound = Nullability.Non_null @@ -774,7 +776,8 @@ module Const = struct linearity = parsed_modifiers.linearity; uniqueness = parsed_modifiers.uniqueness; portability = parsed_modifiers.portability; - contention = parsed_modifiers.contention + contention = parsed_modifiers.contention; + yielding = parsed_modifiers.yielding } in { layout = base.layout; @@ -1165,7 +1168,8 @@ let for_arrow = areality = Locality.Const.max; uniqueness = Uniqueness.Const.min; portability = Portability.Const.max; - contention = Contention.Const.min + contention = Contention.Const.min; + yielding = Yielding.Const.max }; externality_upper_bound = Externality.max; nullability_upper_bound = Non_null diff --git a/typing/jkind_axis.ml b/typing/jkind_axis.ml index b81e66ad8ba..383cc942db8 100644 --- a/typing/jkind_axis.ml +++ b/typing/jkind_axis.ml @@ -142,6 +142,7 @@ module Axis = struct | Uniqueness : Mode.Uniqueness.Const.t t | Portability : Mode.Portability.Const.t t | Contention : Mode.Contention.Const.t t + | Yielding : Mode.Yielding.Const.t t end module Nonmodal = struct @@ -180,6 +181,8 @@ module Axis = struct (module Accent_lattice (Mode.Portability.Const) : Axis_s with type t = a) | Modal Contention -> (module Accent_lattice (Mode.Contention.Const) : Axis_s with type t = a) + | Modal Yielding -> + (module Accent_lattice (Mode.Yielding.Const) : Axis_s with type t = a) | Nonmodal Externality -> (module Externality : Axis_s with type t = a) | Nonmodal Nullability -> (module Nullability : Axis_s with type t = a) @@ -189,6 +192,7 @@ module Axis = struct Pack (Modal Uniqueness); Pack (Modal Portability); Pack (Modal Contention); + Pack (Modal Yielding); Pack (Nonmodal Externality); Pack (Nonmodal Nullability) ] @@ -198,6 +202,7 @@ module Axis = struct | Modal Uniqueness -> "uniqueness" | Modal Portability -> "portability" | Modal Contention -> "contention" + | Modal Yielding -> "yielding" | Nonmodal Externality -> "externality" | Nonmodal Nullability -> "nullability" end @@ -210,6 +215,7 @@ module Axis_collection (T : Misc.T1) = struct uniqueness : Mode.Uniqueness.Const.t T.t; portability : Mode.Portability.Const.t T.t; contention : Mode.Contention.Const.t T.t; + yielding : Mode.Yielding.Const.t T.t; externality : Externality.t T.t; nullability : Nullability.t T.t } @@ -221,6 +227,7 @@ module Axis_collection (T : Misc.T1) = struct | Modal Uniqueness -> values.uniqueness | Modal Portability -> values.portability | Modal Contention -> values.contention + | Modal Yielding -> values.yielding | Nonmodal Externality -> values.externality | Nonmodal Nullability -> values.nullability @@ -231,6 +238,7 @@ module Axis_collection (T : Misc.T1) = struct | Modal Uniqueness -> { values with uniqueness = value } | Modal Portability -> { values with portability = value } | Modal Contention -> { values with contention = value } + | Modal Yielding -> { values with yielding = value } | Nonmodal Externality -> { values with externality = value } | Nonmodal Nullability -> { values with nullability = value } @@ -246,6 +254,7 @@ module Axis_collection (T : Misc.T1) = struct uniqueness = f ~axis:Axis.(Modal Uniqueness); portability = f ~axis:Axis.(Modal Portability); contention = f ~axis:Axis.(Modal Contention); + yielding = f ~axis:Axis.(Modal Yielding); externality = f ~axis:Axis.(Nonmodal Externality); nullability = f ~axis:Axis.(Nonmodal Nullability) } diff --git a/typing/jkind_axis.mli b/typing/jkind_axis.mli index c3cf2aa42af..6ee32d23316 100644 --- a/typing/jkind_axis.mli +++ b/typing/jkind_axis.mli @@ -64,6 +64,7 @@ module Axis : sig | Uniqueness : Mode.Uniqueness.Const.t t | Portability : Mode.Portability.Const.t t | Contention : Mode.Contention.Const.t t + | Yielding : Mode.Yielding.Const.t t end module Nonmodal : sig @@ -98,6 +99,7 @@ module Axis_collection (T : Misc.T1) : sig uniqueness : Mode.Uniqueness.Const.t T.t; portability : Mode.Portability.Const.t T.t; contention : Mode.Contention.Const.t T.t; + yielding : Mode.Yielding.Const.t T.t; externality : Externality.t T.t; nullability : Nullability.t T.t } diff --git a/typing/mode.ml b/typing/mode.ml index b72beee20f2..103631f5b4a 100644 --- a/typing/mode.ml +++ b/typing/mode.ml @@ -317,6 +317,41 @@ module Lattices = struct module Contention_op = Opposite (Contention) + module Yielding = struct + type t = + | Yielding + | Unyielding + + include Total (struct + type nonrec t = t + + let min = Unyielding + + let max = Yielding + + let legacy = Unyielding + + let le a b = + match a, b with + | Unyielding, _ | _, Yielding -> true + | Yielding, Unyielding -> false + + let join a b = + match a, b with + | Yielding, _ | _, Yielding -> Yielding + | Unyielding, Unyielding -> Unyielding + + let meet a b = + match a, b with + | Unyielding, _ | _, Unyielding -> Unyielding + | Yielding, Yielding -> Yielding + + let print ppf = function + | Yielding -> Format.fprintf ppf "yielding" + | Unyielding -> Format.fprintf ppf "unyielding" + end) + end + type monadic = Uniqueness.t * Contention.t module Monadic = struct @@ -343,37 +378,50 @@ module Lattices = struct Format.fprintf ppf "%a,%a" Uniqueness.print a0 Contention.print a1 end - type 'areality comonadic_with = 'areality * Linearity.t * Portability.t + type 'areality comonadic_with = + 'areality * Linearity.t * Portability.t * Yielding.t module Comonadic_with (Areality : Areality) = struct type t = Areality.t comonadic_with - let min = Areality.min, Linearity.min, Portability.min + let min = Areality.min, Linearity.min, Portability.min, Yielding.min - let max = Areality.max, Linearity.max, Portability.max + let max = Areality.max, Linearity.max, Portability.max, Yielding.max - let legacy = Areality.legacy, Linearity.legacy, Portability.legacy + let legacy = + Areality.legacy, Linearity.legacy, Portability.legacy, Yielding.legacy - let le (a0, a1, a2) (b0, b1, b2) = + let le (a0, a1, a2, a3) (b0, b1, b2, b3) = Areality.le a0 b0 && Linearity.le a1 b1 && Portability.le a2 b2 - - let join (a0, a1, a2) (b0, b1, b2) = - Areality.join a0 b0, Linearity.join a1 b1, Portability.join a2 b2 - - let meet (a0, a1, a2) (b0, b1, b2) = - Areality.meet a0 b0, Linearity.meet a1 b1, Portability.meet a2 b2 - - let imply (a0, a1, a2) (b0, b1, b2) = - Areality.imply a0 b0, Linearity.imply a1 b1, Portability.imply a2 b2 - - let subtract (a0, a1, a2) (b0, b1, b2) = + && Yielding.le a3 b3 + + let join (a0, a1, a2, a3) (b0, b1, b2, b3) = + ( Areality.join a0 b0, + Linearity.join a1 b1, + Portability.join a2 b2, + Yielding.join a3 b3 ) + + let meet (a0, a1, a2, a3) (b0, b1, b2, b3) = + ( Areality.meet a0 b0, + Linearity.meet a1 b1, + Portability.meet a2 b2, + Yielding.meet a3 b3 ) + + let imply (a0, a1, a2, a3) (b0, b1, b2, b3) = + ( Areality.imply a0 b0, + Linearity.imply a1 b1, + Portability.imply a2 b2, + Yielding.imply a3 b3 ) + + let subtract (a0, a1, a2, a3) (b0, b1, b2, b3) = ( Areality.subtract a0 b0, Linearity.subtract a1 b1, - Portability.subtract a2 b2 ) + Portability.subtract a2 b2, + Yielding.subtract a3 b3 ) - let print ppf (a0, a1, a2) = - Format.fprintf ppf "%a,%a,%a" Areality.print a0 Linearity.print a1 - Portability.print a2 + let print ppf (a0, a1, a2, a3) = + Format.fprintf ppf "%a,%a,%a,%a" Areality.print a0 Linearity.print a1 + Portability.print a2 Yielding.print a3 end [@@inline] @@ -392,6 +440,7 @@ module Lattices = struct | Uniqueness_op : Uniqueness_op.t obj | Linearity : Linearity.t obj | Portability : Portability.t obj + | Yielding : Yielding.t obj | Contention_op : Contention_op.t obj | Monadic_op : Monadic_op.t obj | Comonadic_with_regionality : Comonadic_with_regionality.t obj @@ -404,6 +453,7 @@ module Lattices = struct | Uniqueness_op -> Format.fprintf ppf "Uniqueness_op" | Linearity -> Format.fprintf ppf "Linearity" | Portability -> Format.fprintf ppf "Portability" + | Yielding -> Format.fprintf ppf "Yielding" | Contention_op -> Format.fprintf ppf "Contention_op" | Monadic_op -> Format.fprintf ppf "Monadic_op" | Comonadic_with_locality -> Format.fprintf ppf "Comonadic_with_locality" @@ -415,6 +465,7 @@ module Lattices = struct | Regionality -> Regionality.min | Uniqueness_op -> Uniqueness_op.min | Contention_op -> Contention_op.min + | Yielding -> Yielding.min | Linearity -> Linearity.min | Portability -> Portability.min | Monadic_op -> Monadic_op.min @@ -428,6 +479,7 @@ module Lattices = struct | Contention_op -> Contention_op.max | Linearity -> Linearity.max | Portability -> Portability.max + | Yielding -> Yielding.max | Monadic_op -> Monadic_op.max | Comonadic_with_locality -> Comonadic_with_locality.max | Comonadic_with_regionality -> Comonadic_with_regionality.max @@ -441,6 +493,7 @@ module Lattices = struct | Contention_op -> Contention_op.le a b | Linearity -> Linearity.le a b | Portability -> Portability.le a b + | Yielding -> Yielding.le a b | Monadic_op -> Monadic_op.le a b | Comonadic_with_locality -> Comonadic_with_locality.le a b | Comonadic_with_regionality -> Comonadic_with_regionality.le a b @@ -454,6 +507,7 @@ module Lattices = struct | Contention_op -> Contention_op.join a b | Linearity -> Linearity.join a b | Portability -> Portability.join a b + | Yielding -> Yielding.join a b | Monadic_op -> Monadic_op.join a b | Comonadic_with_locality -> Comonadic_with_locality.join a b | Comonadic_with_regionality -> Comonadic_with_regionality.join a b @@ -467,6 +521,7 @@ module Lattices = struct | Contention_op -> Contention_op.meet a b | Linearity -> Linearity.meet a b | Portability -> Portability.meet a b + | Yielding -> Yielding.meet a b | Monadic_op -> Monadic_op.meet a b | Comonadic_with_locality -> Comonadic_with_locality.meet a b | Comonadic_with_regionality -> Comonadic_with_regionality.meet a b @@ -480,6 +535,7 @@ module Lattices = struct | Contention_op -> Contention_op.imply a b | Linearity -> Linearity.imply a b | Portability -> Portability.imply a b + | Yielding -> Yielding.imply a b | Comonadic_with_locality -> Comonadic_with_locality.imply a b | Comonadic_with_regionality -> Comonadic_with_regionality.imply a b | Monadic_op -> Monadic_op.imply a b @@ -493,6 +549,7 @@ module Lattices = struct | Contention_op -> Contention_op.subtract a b | Linearity -> Linearity.subtract a b | Portability -> Portability.subtract a b + | Yielding -> Yielding.subtract a b | Comonadic_with_locality -> Comonadic_with_locality.subtract a b | Comonadic_with_regionality -> Comonadic_with_regionality.subtract a b | Monadic_op -> Monadic_op.subtract a b @@ -505,6 +562,7 @@ module Lattices = struct | Contention_op -> Contention_op.print | Linearity -> Linearity.print | Portability -> Portability.print + | Yielding -> Yielding.print | Monadic_op -> Monadic_op.print | Comonadic_with_locality -> Comonadic_with_locality.print | Comonadic_with_regionality -> Comonadic_with_regionality.print @@ -521,11 +579,12 @@ module Lattices = struct | Contention_op, Contention_op -> Some Refl | Linearity, Linearity -> Some Refl | Portability, Portability -> Some Refl + | Yielding, Yielding -> Some Refl | Monadic_op, Monadic_op -> Some Refl | Comonadic_with_locality, Comonadic_with_locality -> Some Refl | Comonadic_with_regionality, Comonadic_with_regionality -> Some Refl | ( ( Locality | Regionality | Uniqueness_op | Contention_op | Linearity - | Portability | Monadic_op | Comonadic_with_locality + | Portability | Yielding | Monadic_op | Comonadic_with_locality | Comonadic_with_regionality ), _ ) -> None @@ -542,6 +601,7 @@ module Lattices_mono = struct | Areality : ('a comonadic_with, 'a) t | Linearity : ('areality comonadic_with, Linearity.t) t | Portability : ('areality comonadic_with, Portability.t) t + | Yielding : ('areality comonadic_with, Yielding.t) t | Uniqueness : (Monadic_op.t, Uniqueness_op.t) t | Contention : (Monadic_op.t, Contention_op.t) t @@ -552,6 +612,7 @@ module Lattices_mono = struct | Portability -> Format.fprintf ppf "portability" | Uniqueness -> Format.fprintf ppf "uniqueness" | Contention -> Format.fprintf ppf "contention" + | Yielding -> Format.fprintf ppf "yielding" let eq : type p r0 r1. (p, r0) t -> (p, r1) t -> (r0, r1) Misc.eq option = fun ax0 ax1 -> @@ -561,24 +622,29 @@ module Lattices_mono = struct | Portability, Portability -> Some Refl | Uniqueness, Uniqueness -> Some Refl | Contention, Contention -> Some Refl - | (Areality | Linearity | Uniqueness | Portability | Contention), _ -> + | Yielding, Yielding -> Some Refl + | ( ( Areality | Linearity | Uniqueness | Portability | Contention + | Yielding ), + _ ) -> None let proj : type p r. (p, r) t -> p -> r = fun ax t -> match ax, t with - | Areality, (a, _, _) -> a - | Linearity, (_, lin, _) -> lin - | Portability, (_, _, s) -> s + | Areality, (a, _, _, _) -> a + | Linearity, (_, lin, _, _) -> lin + | Portability, (_, _, s, _) -> s + | Yielding, (_, _, _, yld) -> yld | Uniqueness, (uni, _) -> uni | Contention, (_, con) -> con let update : type p r. (p, r) t -> r -> p -> p = fun ax r t -> match ax, t with - | Areality, (_, lin, portable) -> r, lin, portable - | Linearity, (area, _, portable) -> area, r, portable - | Portability, (area, lin, _) -> area, lin, r + | Areality, (_, lin, portable, yld) -> r, lin, portable, yld + | Linearity, (area, _, portable, yld) -> area, r, portable, yld + | Portability, (area, lin, _, yld) -> area, lin, r, yld + | Yielding, (area, lin, portable, _) -> area, lin, portable, r | Uniqueness, (_, con) -> r, con | Contention, (uni, _) -> uni, r end @@ -733,7 +799,7 @@ module Lattices_mono = struct end) let set_areality : type a0 a1. a1 -> a0 comonadic_with -> a1 comonadic_with = - fun r (_, lin, portable) -> r, lin, portable + fun r (_, lin, portable, yld) -> r, lin, portable, yld let proj_obj : type t r. (t, r) Axis.t -> t obj -> r obj = fun ax obj -> @@ -744,6 +810,8 @@ module Lattices_mono = struct | Linearity, Comonadic_with_regionality -> Linearity | Portability, Comonadic_with_locality -> Portability | Portability, Comonadic_with_regionality -> Portability + | Yielding, Comonadic_with_locality -> Yielding + | Yielding, Comonadic_with_regionality -> Yielding | Uniqueness, Monadic_op -> Uniqueness_op | Contention, Monadic_op -> Contention_op @@ -753,7 +821,7 @@ module Lattices_mono = struct | Locality -> Comonadic_with_locality | Regionality -> Comonadic_with_regionality | Uniqueness_op | Linearity | Monadic_op | Comonadic_with_regionality - | Comonadic_with_locality | Contention_op | Portability -> + | Comonadic_with_locality | Contention_op | Portability | Yielding -> assert false let rec src : type a b d. b obj -> (a, b, d) morph -> a obj = @@ -921,15 +989,17 @@ module Lattices_mono = struct | Comonadic_with_locality -> ( Locality.min, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.min ) | Comonadic_with_regionality -> ( Regionality.min, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.min ) let comonadic_to_monadic : type a. a comonadic_with obj -> a comonadic_with -> Monadic_op.t = - fun obj (_, linearity, portability) -> + fun obj (_, linearity, portability, _) -> match obj with | Comonadic_with_locality -> linear_to_unique linearity, portable_to_contended portability @@ -943,11 +1013,13 @@ module Lattices_mono = struct | Comonadic_with_locality -> ( Locality.max, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.max ) | Comonadic_with_regionality -> ( Regionality.max, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.max ) let rec apply : type a b d. b obj -> (a, b, d) morph -> a -> b = fun dst f a -> @@ -1036,7 +1108,8 @@ module Lattices_mono = struct match ax with | Areality -> Some (compose dst f (Proj (src', Areality))) | Linearity -> Some (Proj (src', Linearity)) - | Portability -> Some (Proj (src', Portability))) + | Portability -> Some (Proj (src', Portability)) + | Yielding -> Some (Proj (src', Yielding))) | Proj _, Monadic_to_comonadic_min -> None | Proj _, Monadic_to_comonadic_max -> None | Proj _, Comonadic_to_monadic _ -> None @@ -1482,6 +1555,24 @@ module Contention = struct let zap_to_legacy = zap_to_floor end +module Yielding = struct + module Const = C.Yielding + + module Obj = struct + type const = Const.t + + module Solver = S.Positive + + let obj = C.Yielding + end + + include Common (Obj) + + let legacy = of_const Const.legacy + + let zap_to_legacy = zap_to_floor +end + let regional_to_local m = S.Positive.via_monotone Locality.Obj.obj C.Regional_to_local m @@ -1562,20 +1653,25 @@ module Comonadic_with (Areality : Areality) = struct let areality = proj Areality m |> Areality.zap_to_legacy in let linearity = proj Linearity m |> Linearity.zap_to_legacy in let portability = proj Portability m |> Portability.zap_to_legacy in - areality, linearity, portability + let yielding = proj Yielding m |> Yielding.zap_to_legacy in + areality, linearity, portability, yielding let imply c m = Solver.via_monotone obj (Imply c) (Solver.disallow_left m) let legacy = of_const Const.legacy - let axis_of_error { left = area0, lin0, port0; right = area1, lin1, port1 } : + let axis_of_error + { left = area0, lin0, port0, yld0; right = area1, lin1, port1, yld1 } : error = if Areality.Const.le area0 area1 then if Linearity.Const.le lin0 lin1 then if Portability.Const.le port0 port1 - then assert false + then + if Yielding.Const.le yld0 yld1 + then assert false + else Error (Yielding, { left = yld0; right = yld1 }) else Error (Portability, { left = port0; right = port1 }) else Error (Linearity, { left = lin0; right = lin1 }) else Error (Areality, { left = area0; right = area1 }) @@ -1713,23 +1809,25 @@ module Value_with (Areality : Areality) = struct | Monadic ax -> Monadic.proj_obj ax | Comonadic ax -> Comonadic.proj_obj ax - type ('a, 'b, 'c, 'd, 'e) modes = + type ('a, 'b, 'c, 'd, 'e, 'f) modes = { areality : 'a; linearity : 'b; uniqueness : 'c; portability : 'd; - contention : 'e + contention : 'e; + yielding : 'f } - let split { areality; linearity; portability; uniqueness; contention } = + let split + { areality; linearity; portability; uniqueness; contention; yielding } = let monadic = uniqueness, contention in - let comonadic = areality, linearity, portability in + let comonadic = areality, linearity, portability, yielding in { comonadic; monadic } let merge { comonadic; monadic } = - let areality, linearity, portability = comonadic in + let areality, linearity, portability, yielding = comonadic in let uniqueness, contention = monadic in - { areality; linearity; portability; uniqueness; contention } + { areality; linearity; portability; uniqueness; contention; yielding } let print ?verbose () ppf { monadic; comonadic } = Format.fprintf ppf "%a;%a" @@ -1750,7 +1848,8 @@ module Value_with (Areality : Areality) = struct Linearity.Const.t, Uniqueness.Const.t, Portability.Const.t, - Contention.Const.t ) + Contention.Const.t, + Yielding.Const.t ) modes module Monadic = Monadic.Const @@ -1794,7 +1893,8 @@ module Value_with (Areality : Areality) = struct Linearity.Const.t option, Uniqueness.Const.t option, Portability.Const.t option, - Contention.Const.t option ) + Contention.Const.t option, + Yielding.Const.t option ) modes let none = @@ -1802,7 +1902,8 @@ module Value_with (Areality : Areality) = struct uniqueness = None; linearity = None; portability = None; - contention = None + contention = None; + yielding = None } let value opt ~default = @@ -1817,15 +1918,17 @@ module Value_with (Areality : Areality) = struct let contention = Option.value opt.contention ~default:default.contention in - { areality; uniqueness; linearity; portability; contention } + let yielding = Option.value opt.yielding ~default:default.yielding in + { areality; uniqueness; linearity; portability; contention; yielding } - let print ppf { areality; uniqueness; linearity; portability; contention } + let print ppf + { areality; uniqueness; linearity; portability; contention; yielding } = let option_print print ppf = function | None -> Format.fprintf ppf "None" | Some a -> Format.fprintf ppf "Some %a" print a in - Format.fprintf ppf "%a,%a,%a,%a,%a" + Format.fprintf ppf "%a,%a,%a,%a,%a,%a" (option_print Areality.Const.print) areality (option_print Linearity.Const.print) @@ -1836,6 +1939,8 @@ module Value_with (Areality : Areality) = struct portability (option_print Contention.Const.print) contention + (option_print Yielding.Const.print) + yielding end let diff m0 m1 = @@ -1847,7 +1952,8 @@ module Value_with (Areality : Areality) = struct diff Portability.Const.le m0.portability m1.portability in let contention = diff Contention.Const.le m0.contention m1.contention in - { areality; linearity; uniqueness; portability; contention } + let yielding = diff Yielding.Const.le m0.yielding m1.yielding in + { areality; linearity; uniqueness; portability; contention; yielding } (** See [Alloc.close_over] for explanation. *) let close_over m = @@ -2139,10 +2245,10 @@ module Alloc = Value_with (Locality) module Const = struct let alloc_as_value - ({ areality; linearity; portability; uniqueness; contention } : + ({ areality; linearity; portability; uniqueness; contention; yielding } : Alloc.Const.t) : Value.Const.t = let areality = C.locality_as_regionality areality in - { areality; linearity; portability; uniqueness; contention } + { areality; linearity; portability; uniqueness; contention; yielding } let locality_as_regionality = C.locality_as_regionality end diff --git a/typing/mode_intf.mli b/typing/mode_intf.mli index 5b0f4897265..5498d636979 100644 --- a/typing/mode_intf.mli +++ b/typing/mode_intf.mli @@ -263,7 +263,26 @@ module type S = sig and type 'd t = (Const.t, 'd) mode_monadic end - type 'a comonadic_with = private 'a * Linearity.Const.t * Portability.Const.t + module Yielding : sig + module Const : sig + type t = + | Yielding + | Unyielding + + include Lattice with type t := t + end + + type error = Const.t Solver.error + + include + Common + with module Const := Const + and type error := error + and type 'd t = (Const.t, 'd) mode_comonadic + end + + type 'a comonadic_with = private + 'a * Linearity.Const.t * Portability.Const.t * Yielding.Const.t type monadic = private Uniqueness.Const.t * Contention.Const.t @@ -274,6 +293,7 @@ module type S = sig | Areality : ('a comonadic_with, 'a) t | Linearity : ('areality comonadic_with, Linearity.Const.t) t | Portability : ('areality comonadic_with, Portability.Const.t) t + | Yielding : ('areality comonadic_with, Yielding.Const.t) t | Uniqueness : (monadic, Uniqueness.Const.t) t | Contention : (monadic, Contention.Const.t) t @@ -317,12 +337,13 @@ module type S = sig (Comonadic.Const.t, 'a) Axis.t -> (('a, 'd) mode_comonadic, 'a, 'd) axis - type ('a, 'b, 'c, 'd, 'e) modes = + type ('a, 'b, 'c, 'd, 'e, 'f) modes = { areality : 'a; linearity : 'b; uniqueness : 'c; portability : 'd; - contention : 'e + contention : 'e; + yielding : 'f } module Const : sig @@ -333,7 +354,8 @@ module type S = sig Linearity.Const.t, Uniqueness.Const.t, Portability.Const.t, - Contention.Const.t ) + Contention.Const.t, + Yielding.Const.t ) modes module Option : sig @@ -344,7 +366,8 @@ module type S = sig Linearity.Const.t option, Uniqueness.Const.t option, Portability.Const.t option, - Contention.Const.t option ) + Contention.Const.t option, + Yielding.Const.t option ) modes val none : t diff --git a/typing/printtyp.ml b/typing/printtyp.ml index e91897f5d75..134d25c9e85 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1419,7 +1419,8 @@ let tree_of_modes modes = tree_of_mode diff.uniqueness [Mode.Uniqueness.Const.Unique, Omd_new "unique"]; tree_of_mode diff.portability [Mode.Portability.Const.Portable, Omd_new "portable"]; tree_of_mode diff.contention [Mode.Contention.Const.Contended, Omd_new "contended"; - Mode.Contention.Const.Shared, Omd_new "shared"]] + Mode.Contention.Const.Shared, Omd_new "shared"]; + tree_of_mode diff.yielding [Mode.Yielding.Const.Yielding, Omd_new "yielding"]] in List.filter_map Fun.id l diff --git a/typing/typecore.ml b/typing/typecore.ml index c45e7c72c10..6f0d087af73 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -10815,6 +10815,7 @@ let report_error ~loc env = function | Error (Monadic Contention, _ ) -> contention_hint fail_reason submode_reason contention_context | Error (Comonadic Portability, _ ) -> [] + | Error (Comonadic Yielding, _) -> [] in Location.errorf ~loc ~sub "@[%t@]" begin match fail_reason with diff --git a/typing/typemode.ml b/typing/typemode.ml index 8cbd18650c7..474f7e524df 100644 --- a/typing/typemode.ml +++ b/typing/typemode.ml @@ -51,6 +51,8 @@ module Axis_pair = struct | "external64" -> Any_axis_pair (Nonmodal Externality, Externality.External64) | "external_" -> Any_axis_pair (Nonmodal Externality, Externality.External) + | "yielding" -> Any_axis_pair (Modal Yielding, Yielding.Const.Yielding) + | "unyielding" -> Any_axis_pair (Modal Yielding, Yielding.Const.Unyielding) | _ -> raise Not_found end @@ -116,7 +118,8 @@ let transl_mode_annots annots : Alloc.Const.Option.t = linearity = modes.linearity; uniqueness = modes.uniqueness; portability = modes.portability; - contention = modes.contention + contention = modes.contention; + yielding = modes.yielding } let untransl_mode_annots ~loc (modes : Mode.Alloc.Const.Option.t) = @@ -134,9 +137,10 @@ let untransl_mode_annots ~loc (modes : Mode.Alloc.Const.Option.t) = let contention = print_to_string_opt Mode.Contention.Const.print modes.contention in + let yielding = print_to_string_opt Mode.Yielding.Const.print modes.yielding in List.filter_map (fun x -> Option.map (fun s -> { txt = Parsetree.Mode s; loc }) x) - [areality; uniqueness; linearity; portability; contention] + [areality; uniqueness; linearity; portability; contention; yielding] let transl_modality ~maturity { txt = Parsetree.Modality modality; loc } = let axis_pair = @@ -155,6 +159,8 @@ let transl_modality ~maturity { txt = Parsetree.Modality modality; loc } = Modality.Atom (Comonadic Portability, Meet_with mode) | Modal_axis_pair (Contention, mode) -> Modality.Atom (Monadic Contention, Join_with mode) + | Modal_axis_pair (Yielding, mode) -> + Modality.Atom (Comonadic Yielding, Meet_with mode) let untransl_modality (a : Modality.t) : Parsetree.modality loc = let s = @@ -174,6 +180,9 @@ let untransl_modality (a : Modality.t) : Parsetree.modality loc = | Atom (Monadic Contention, Join_with Contention.Const.Shared) -> "shared" | Atom (Monadic Contention, Join_with Contention.Const.Uncontended) -> "uncontended" + | Atom (Comonadic Yielding, Meet_with Yielding.Const.Yielding) -> "yielding" + | Atom (Comonadic Yielding, Meet_with Yielding.Const.Unyielding) -> + "unyielding" | _ -> failwith "BUG: impossible modality atom" in { txt = Modality s; loc = Location.none } @@ -188,7 +197,8 @@ let mutable_implied_modalities (mut : Types.mutability) attrs = let comonadic : Modality.t list = [ Atom (Comonadic Areality, Meet_with Regionality.Const.legacy); Atom (Comonadic Linearity, Meet_with Linearity.Const.legacy); - Atom (Comonadic Portability, Meet_with Portability.Const.legacy) ] + Atom (Comonadic Portability, Meet_with Portability.Const.legacy); + Atom (Comonadic Yielding, Meet_with Yielding.Const.legacy) ] in let monadic : Modality.t list = [ Atom (Monadic Uniqueness, Join_with Uniqueness.Const.legacy); From d40254f0b0164d6a32fa548d2eb559126a3493b5 Mon Sep 17 00:00:00 2001 From: Stephen Dolan Date: Tue, 7 Jan 2025 21:25:45 +0000 Subject: [PATCH 22/30] Move two misplaced files (#3435) --- .../tests/polling/polling.compilers.reference | 0 {ocaml/testsuite => testsuite}/tests/polling/polling.ml | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {ocaml/testsuite => testsuite}/tests/polling/polling.compilers.reference (100%) rename {ocaml/testsuite => testsuite}/tests/polling/polling.ml (100%) diff --git a/ocaml/testsuite/tests/polling/polling.compilers.reference b/testsuite/tests/polling/polling.compilers.reference similarity index 100% rename from ocaml/testsuite/tests/polling/polling.compilers.reference rename to testsuite/tests/polling/polling.compilers.reference diff --git a/ocaml/testsuite/tests/polling/polling.ml b/testsuite/tests/polling/polling.ml similarity index 100% rename from ocaml/testsuite/tests/polling/polling.ml rename to testsuite/tests/polling/polling.ml From 648155d6fdbd1210048bc2161dceaa79f098305f Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Thu, 9 Jan 2025 13:09:48 +0000 Subject: [PATCH 23/30] Add [Printreg.reglist] for debugging (#3444) --- backend/printreg.ml | 2 ++ backend/printreg.mli | 2 ++ 2 files changed, 4 insertions(+) diff --git a/backend/printreg.ml b/backend/printreg.ml index 68f7e51d670..74967756835 100644 --- a/backend/printreg.ml +++ b/backend/printreg.ml @@ -63,6 +63,8 @@ let regs' ?(print_reg = reg) ppf v = let regs ppf v = regs' ppf v +let reglist ppf l = Format.pp_print_list ~pp_sep:pp_print_space reg ppf l + let regset ppf s = let first = ref true in Set.iter diff --git a/backend/printreg.mli b/backend/printreg.mli index fa1979970b8..9857dcaf8a9 100644 --- a/backend/printreg.mli +++ b/backend/printreg.mli @@ -37,6 +37,8 @@ val regs : Format.formatter -> Reg.t array -> unit val regset : Format.formatter -> Reg.Set.t -> unit +val reglist : Format.formatter -> Reg.t list -> unit + val regsetaddr' : ?print_reg:(Format.formatter -> Reg.t -> unit) -> Format.formatter -> From 157c95e9051b76531dcdb1d6c426ece8f213cb59 Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Thu, 9 Jan 2025 13:15:33 +0000 Subject: [PATCH 24/30] Vectorizer bug fix: 128-bit vectorized constant (#3447) Fix bug: 128-bit vectorized constant high/low correctly ordered --- backend/amd64/simd_selection.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/amd64/simd_selection.ml b/backend/amd64/simd_selection.ml index 526d37d3f11..1e78dda0510 100644 --- a/backend/amd64/simd_selection.ml +++ b/backend/amd64/simd_selection.ml @@ -491,7 +491,7 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) ~res_count operation ] in let create_const_vec consts = - let highs, lows = Misc.Stdlib.List.split_at (length / 2) consts in + let lows, highs = Misc.Stdlib.List.split_at (length / 2) consts in let pack_int64 nums = let mask = Int64.shift_right_logical Int64.minus_one (64 - width_in_bits) From 830d5e74e4e1b7f088e65ef456c1886e3e5a5084 Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Thu, 9 Jan 2025 13:15:59 +0000 Subject: [PATCH 25/30] Add "dump-vectorize" to OCAMLPARAM (#3443) Add [dump-vectorize] to OCAMLPARAM for debugging --- driver/flambda_backend_args.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml index 44ade683f79..1e2458562dd 100644 --- a/driver/flambda_backend_args.ml +++ b/driver/flambda_backend_args.ml @@ -1365,6 +1365,7 @@ module Extra_params = struct | "regalloc-param" -> add_string Flambda_backend_flags.regalloc_params | "regalloc-validate" -> set' Flambda_backend_flags.regalloc_validate | "vectorize" -> set' Flambda_backend_flags.vectorize + | "dump-vectorize" -> set' Flambda_backend_flags.dump_vectorize | "vectorize-max-block-size" -> set_int' Flambda_backend_flags.vectorize_max_block_size | "cfg-selection" -> set' Flambda_backend_flags.cfg_selection | "cfg-peephole-optimize" -> set' Flambda_backend_flags.cfg_peephole_optimize From c0489200d6703f203c5693e15d3a78b73ad0e94b Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Thu, 9 Jan 2025 13:16:36 +0000 Subject: [PATCH 26/30] Cleanup machtype_component size (#3441) Cleanup size_component --- backend/amd64/emit.mlp | 2 +- backend/reg.ml | 12 ------------ backend/reg.mli | 2 -- backend/select_utils.ml | 2 ++ 4 files changed, 3 insertions(+), 15 deletions(-) diff --git a/backend/amd64/emit.mlp b/backend/amd64/emit.mlp index fd09de7040f..84f2344d6cc 100644 --- a/backend/amd64/emit.mlp +++ b/backend/amd64/emit.mlp @@ -2316,7 +2316,7 @@ let emit_probe_notes0 () = Misc.fatal_errorf "Cannot create probe: illegal argument: %a" Printreg.reg arg in - Printf.sprintf "%d@%s" (Reg.size_of_contents_in_bytes arg) arg_name + Printf.sprintf "%d@%s" (Select_utils.size_component arg.Reg.typ) arg_name in let describe_one_probe p = let probe_name, enabled_at_init = diff --git a/backend/reg.ml b/backend/reg.ml index 78077b04e78..e1c9cb18efc 100644 --- a/backend/reg.ml +++ b/backend/reg.ml @@ -193,18 +193,6 @@ let is_reg t = | Reg _ -> true | _ -> false -let size_of_contents_in_bytes t = - match t.typ with - | Vec128 -> Arch.size_vec128 - | Float -> Arch.size_float - | Float32 -> - assert (Arch.size_float = 8); - Arch.size_float / 2 - | Addr -> - assert (Arch.size_addr = Arch.size_int); - Arch.size_addr - | Int | Val -> Arch.size_int - let reset() = (* When reset() is called for the first time, the current stamp reflects all hard pseudo-registers that have been allocated by Proc, so diff --git a/backend/reg.mli b/backend/reg.mli index 328f4e7e7a1..663780add11 100644 --- a/backend/reg.mli +++ b/backend/reg.mli @@ -102,8 +102,6 @@ val name : t -> string val is_reg : t -> bool val is_stack : t -> bool -val size_of_contents_in_bytes : t -> int - module Set: Set.S with type elt = t module Map: Map.S with type key = t module Tbl: Hashtbl.S with type key = t diff --git a/backend/select_utils.ml b/backend/select_utils.ml index 6b56f570f3d..3387ce669af 100644 --- a/backend/select_utils.ml +++ b/backend/select_utils.ml @@ -208,6 +208,8 @@ let oper_result_type = function (* Infer the size in bytes of the result of an expression whose evaluation may be deferred (cf. [emit_parts]). *) +(* [size_component] is placed here and not in [Cmm] to avoid cyclic + dependencies, because it uses [Arch]. *) let size_component : machtype_component -> int = function | Val | Addr -> Arch.size_addr | Int -> Arch.size_int From bd39e023864db710fbc40d0f6827eb76e0cfa514 Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Fri, 10 Jan 2025 10:24:48 +0000 Subject: [PATCH 27/30] Add function [DLL.for_all_i] (#3442) * Add function [DLL.for_all_i] * Rename to [for_alli] to match existing [mapi] and [iteri] * Remove unused argument of [aux] in [DLL.for_all*] --- utils/doubly_linked_list.ml | 14 +++++++++++--- utils/doubly_linked_list.mli | 2 ++ 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/utils/doubly_linked_list.ml b/utils/doubly_linked_list.ml index b4a1f7c37ca..7f6efc2ebd7 100644 --- a/utils/doubly_linked_list.ml +++ b/utils/doubly_linked_list.ml @@ -333,12 +333,20 @@ let exists t ~f = aux t f t.first let for_all t ~f = - let rec aux t f curr = + let rec aux f curr = match curr with | Empty -> true - | Node node -> if f node.value then aux t f node.next else false + | Node node -> if f node.value then aux f node.next else false in - aux t f t.first + aux f t.first + +let for_alli t ~f = + let rec aux f i curr = + match curr with + | Empty -> true + | Node node -> if f i node.value then aux f (i + 1) node.next else false + in + aux f 0 t.first let to_list t = fold_right t ~f:(fun hd tl -> hd :: tl) ~init:[] diff --git a/utils/doubly_linked_list.mli b/utils/doubly_linked_list.mli index a2f406aff4b..32d572f7a73 100644 --- a/utils/doubly_linked_list.mli +++ b/utils/doubly_linked_list.mli @@ -78,6 +78,8 @@ val exists : 'a t -> f:('a -> bool) -> bool val for_all : 'a t -> f:('a -> bool) -> bool +val for_alli : 'a t -> f:(int -> 'a -> bool) -> bool + val to_list : 'a t -> 'a list (* Adds all of the elements of `from` to `to_`, and clears `from`. *) From cb290c5bea898102eccd82aa189c51708cedb780 Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Fri, 10 Jan 2025 11:00:32 +0000 Subject: [PATCH 28/30] Vectorizer: rename New (#3454) Rename New to New_vec128 to make the type clear and distinguish it from the upcoming Valx2 --- backend/amd64/simd_selection.ml | 28 ++++++++++++++-------------- backend/cfg/vectorize.ml | 2 +- backend/vectorize_utils.ml | 2 +- backend/vectorize_utils.mli | 2 +- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/backend/amd64/simd_selection.ml b/backend/amd64/simd_selection.ml index 1e78dda0510..5cac65691bb 100644 --- a/backend/amd64/simd_selection.ml +++ b/backend/amd64/simd_selection.ml @@ -703,9 +703,9 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) then ( assert (arg_count = 1 && res_count = 1); const_instruction.results.(0) - <- Vectorize_utils.Vectorized_instruction.New 0; + <- Vectorize_utils.Vectorized_instruction.New_Vec128 0; intop_instruction.arguments.(1) - <- Vectorize_utils.Vectorized_instruction.New 0; + <- Vectorize_utils.Vectorized_instruction.New_Vec128 0; Some [const_instruction; intop_instruction]) else None | _ -> None) @@ -776,8 +776,8 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) (* reg + displ *) Some [ make_move (Argument 0) (Result 0); - make_const (New 0) displs; - make_binary_operation (Result 0) (New 0) (Result 0) add ] + make_const (New_Vec128 0) displs; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) add ] | None -> None) | Iindexed2 _ -> ( match add_op with @@ -788,8 +788,8 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) Some [ make_move (Argument 0) (Result 0); make_binary_operation (Result 0) (Argument 1) (Result 0) add; - make_const (New 0) displs; - make_binary_operation (Result 0) (New 0) (Result 0) add ] + make_const (New_Vec128 0) displs; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) add ] | None -> None) | Iscaled _ -> ( match add_op, mul_op with @@ -800,10 +800,10 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) (* reg * scale + displ *) Some [ make_move (Argument 0) (Result 0); - make_const (New 0) scales; - make_binary_operation (Result 0) (New 0) (Result 0) mul; - make_const (New 1) displs; - make_binary_operation (Result 0) (New 1) (Result 0) add ] + make_const (New_Vec128 0) scales; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) mul; + make_const (New_Vec128 1) displs; + make_binary_operation (Result 0) (New_Vec128 1) (Result 0) add ] | _ -> None) | Iindexed2scaled _ -> ( match add_op, mul_op with @@ -814,11 +814,11 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) (* reg + reg * scale + displ *) Some [ make_move (Argument 1) (Result 0); - make_const (New 0) scales; - make_binary_operation (Result 0) (New 0) (Result 0) mul; + make_const (New_Vec128 0) scales; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) mul; make_binary_operation (Result 0) (Argument 0) (Result 0) add; - make_const (New 1) displs; - make_binary_operation (Result 0) (New 1) (Result 0) add ] + make_const (New_Vec128 1) displs; + make_binary_operation (Result 0) (New_Vec128 1) (Result 0) add ] | _ -> None) | Ibased _ -> None) | Isextend32 -> ( diff --git a/backend/cfg/vectorize.ml b/backend/cfg/vectorize.ml index 77703302f84..ad5d5362d6a 100644 --- a/backend/cfg/vectorize.ml +++ b/backend/cfg/vectorize.ml @@ -2888,7 +2888,7 @@ let add_vector_instructions_for_group reg_map state group ~before:cell let get_register (simd_reg : Vectorize_utils.Vectorized_instruction.register) = match simd_reg with - | New n -> get_new_reg n + | New_Vec128 n -> get_new_reg n | Argument n -> let original_reg = (Instruction.arguments key_instruction).(n) in Substitution.get_reg_exn reg_map original_reg diff --git a/backend/vectorize_utils.ml b/backend/vectorize_utils.ml index f119306bbe8..83b88112ae3 100644 --- a/backend/vectorize_utils.ml +++ b/backend/vectorize_utils.ml @@ -76,7 +76,7 @@ end module Vectorized_instruction = struct type register = - | New of int + | New_Vec128 of int | Argument of int | Result of int | Original of int diff --git a/backend/vectorize_utils.mli b/backend/vectorize_utils.mli index 43e6961f35a..f3bfe8fda72 100644 --- a/backend/vectorize_utils.mli +++ b/backend/vectorize_utils.mli @@ -59,7 +59,7 @@ module Vectorized_instruction : sig (** Registers used in vectorized instructions of one scalar instruction group. *) type register = - | New of int + | New_Vec128 of int (** The n-th new temporary register used in the vectorized instructions *) | Argument of int (** Vector version of the n-th argument's register of the scalar From c30ec741861b9d69fe114eb552d1d532559ac853 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa <51928404+rtjoa@users.noreply.github.com> Date: Fri, 10 Jan 2025 10:41:08 -0500 Subject: [PATCH 29/30] Check for type recursion without boxing (#3407) --- testsuite/tests/letrec-check/unboxed.ml | 13 +- .../tests/typing-layouts-products/letrec.ml | 13 +- .../typing-layouts-products/recursive.ml | 541 +++++++++++++----- .../unboxed_records_alpha.ml | 13 +- testsuite/tests/typing-unboxed-types/test.ml | 51 +- testsuite/tests/typing-unboxed/test.ml | 6 +- typing/ctype.ml | 14 + typing/ctype.mli | 4 + typing/typedecl.ml | 123 +++- typing/typedecl.mli | 1 + 10 files changed, 619 insertions(+), 160 deletions(-) diff --git a/testsuite/tests/letrec-check/unboxed.ml b/testsuite/tests/letrec-check/unboxed.ml index 2ebc1c74e69..8e80fa719eb 100644 --- a/testsuite/tests/letrec-check/unboxed.ml +++ b/testsuite/tests/letrec-check/unboxed.ml @@ -23,14 +23,17 @@ Line 2, characters 12-19: Error: This kind of expression is not allowed as right-hand side of "let rec" |}];; +(* This test was made to error by disallowing singleton recursive unboxed types. + We keep it in case these are re-allowed, in which case it should error with: + [This kind of expression is not allowed as right-hand side of "let rec"] *) type r = A of r [@@unboxed] let rec y = A y;; [%%expect{| -type r = A of r [@@unboxed] -Line 2, characters 12-15: -2 | let rec y = A y;; - ^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" +Line 1, characters 0-27: +1 | type r = A of r [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "r" is recursive without boxing: + "r" contains "r" |}];; (* This test is not allowed if 'a' is unboxed, but should be accepted diff --git a/testsuite/tests/typing-layouts-products/letrec.ml b/testsuite/tests/typing-layouts-products/letrec.ml index 5e0afabb196..81ad1611598 100644 --- a/testsuite/tests/typing-layouts-products/letrec.ml +++ b/testsuite/tests/typing-layouts-products/letrec.ml @@ -6,14 +6,17 @@ } *) +(* This test was made to error by disallowing singleton recursive unboxed types. + We keep it in case these are re-allowed, in which case it should error with: + [This kind of expression is not allowed as right-hand side of "let rec"] *) type t : value = #{ t : t } let rec t = #{ t = t } [%%expect{| -type t = #{ t : t; } -Line 2, characters 12-22: -2 | let rec t = #{ t = t } - ^^^^^^^^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" +Line 1, characters 0-27: +1 | type t : value = #{ t : t } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t" is recursive without boxing: + "t" contains "t" |}] type bx = { bx : ubx } diff --git a/testsuite/tests/typing-layouts-products/recursive.ml b/testsuite/tests/typing-layouts-products/recursive.ml index 0ff208ffbc5..48b586ec093 100644 --- a/testsuite/tests/typing-layouts-products/recursive.ml +++ b/testsuite/tests/typing-layouts-products/recursive.ml @@ -6,59 +6,119 @@ } *) -(* CR layouts v7.2: figure out the story for recursive unboxed products. - Consider that the following is allowed upstream: - type t = { t : t } [@@unboxed] - We should also give good errors for infinite-size unboxed records (see the - test at the bottom of this file with a depth-100 kind). -*) +(* We only allow recursion of unboxed product types through boxing, otherwise + the type is uninhabitable and usually also infinite-size. *) -(************************************) -(* Basic recursive unboxed products *) +(***********************************************) +(* Allowed (guarded) recursive unboxed records *) -type t : value = #{ t : t } +(* Guarded by `list` *) +type t = #{ tl: t list } [%%expect{| -type t = #{ t : t; } +type t = #{ tl : t list; } |}] -type t : float64 = #{ t : t } +module AbstractList : sig + type 'a t +end = struct + type 'a t = Cons of 'a * 'a list | Nil +end [%%expect{| -type t = #{ t : t; } +module AbstractList : sig type 'a t end |}] +type t = #{ tl: t AbstractList.t } +[%%expect{| +type t = #{ tl : t AbstractList.t; } +|}] -type t : value = #{ t : t } +type 'a mylist = Cons of 'a * 'a list | Nil +and t = { t : t mylist } [@@unboxed] [%%expect{| -type t = #{ t : t; } +type 'a mylist = Cons of 'a * 'a list | Nil +and t = { t : t mylist; } [@@unboxed] |}] -(* CR layouts v7.2: Once we support unboxed records with elements of kind [any], - and detect bad recursive unboxed records with an occurs check, this error - should improve. -*) -type bad = #{ bad : bad ; i : int} +(* This passes the unboxed recursion check (as [pair] always has jkind + [value & value], [(int, bad) pair] is indeed finite-size, but it fails the + jkind check *) +type ('a, 'b) pair = #{ a : 'a ; b : 'b } +type bad = #{ bad : (int, bad) pair } [%%expect{| -Line 1, characters 0-34: -1 | type bad = #{ bad : bad ; i : int} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +type ('a, 'b) pair = #{ a : 'a; b : 'b; } +Line 2, characters 0-37: +2 | type bad = #{ bad : (int, bad) pair } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: - The layout of bad is any & any - because it is an unboxed record. - But the layout of bad must be representable - because it is the type of record field bad. + The layout of bad is value & value + because of the definition of pair at line 1, characters 0-41. + But the layout of bad must be a sublayout of value + because of the definition of pair at line 1, characters 0-41. |}] -type bad = #{ bad : bad } +(* This fails the unboxed recursion check; we must look into [pair] since it's + part of the same mutually recursive type decl. *) +type ('a, 'b) pair = #{ a : 'a ; b : 'b } +and bad = #{ bad : (int, bad) pair } [%%expect{| -Line 1, characters 0-25: -1 | type bad = #{ bad : bad } - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of bad is any - because a dummy kind of any is used to check mutually recursive datatypes. - Please notify the Jane Street compilers group if you see this output. - But the layout of bad must be representable - because it is the type of record field bad. +Line 2, characters 0-36: +2 | and bad = #{ bad : (int, bad) pair } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "(int, bad) pair", + "(int, bad) pair" contains "bad" +|}] + +(* Guarded by a function *) +type t = #{ f1 : t -> t ; f2 : t -> t } +[%%expect{| +type t = #{ f1 : t -> t; f2 : t -> t; } +|}] + +(* Guarded by a tuple *) +type a = #{ b : b } +and b = a * a +[%%expect{| +type a = #{ b : b; } +and b = a * a +|}] + +(* Guarded by a function *) +type a = #{ b : b } +and b = #{ c1 : c ; c2 : c } +and c = unit -> a +[%%expect{| +type a = #{ b : b; } +and b = #{ c1 : c; c2 : c; } +and c = unit -> a +|}] + +(* Recursion through modules guarded by a function *) +module rec A : sig + type t = #{ b1 : B.t ; b2 : B.t } +end = struct + type t = #{ b1 : B.t ; b2 : B.t } +end +and B : sig + type t = unit -> A.t +end = struct + type t = unit -> A.t +end +[%%expect{| +module rec A : sig type t = #{ b1 : B.t; b2 : B.t; } end +and B : sig type t = unit -> A.t end +|}] + +(**********************************) +(* Infinite-sized unboxed records *) + +type bad = #{ bad : bad ; i : int} +[%%expect{| +Line 1, characters 0-34: +1 | type bad = #{ bad : bad ; i : int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" |}] type a_bad = #{ b_bad : b_bad } @@ -67,12 +127,9 @@ and b_bad = #{ a_bad : a_bad } Line 1, characters 0-31: 1 | type a_bad = #{ b_bad : b_bad } ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of a_bad is any - because a dummy kind of any is used to check mutually recursive datatypes. - Please notify the Jane Street compilers group if you see this output. - But the layout of a_bad must be representable - because it is the type of record field a_bad. +Error: The definition of "a_bad" is recursive without boxing: + "a_bad" contains "b_bad", + "b_bad" contains "a_bad" |}] type bad : any = #{ bad : bad } @@ -80,23 +137,46 @@ type bad : any = #{ bad : bad } Line 1, characters 0-31: 1 | type bad : any = #{ bad : bad } ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of bad is any - because of the annotation on the declaration of the type bad. - But the layout of bad must be representable - because it is the type of record field bad. +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" |}] -type 'a id = #{ a : 'a } -type bad = bad id +type bad = #{ x : #(int * u) } +and u = T of bad [@@unboxed] [%%expect{| -type 'a id = #{ a : 'a; } -Line 2, characters 0-17: -2 | type bad = bad id - ^^^^^^^^^^^^^^^^^ +Line 1, characters 0-30: +1 | type bad = #{ x : #(int * u) } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "u", + "u" contains "bad" +|}] + +type 'a record_id = #{ a : 'a } +type 'a alias_id = 'a +[%%expect{| +type 'a record_id = #{ a : 'a; } +type 'a alias_id = 'a +|}] + +type bad = bad record_id +[%%expect{| +Line 1, characters 0-24: +1 | type bad = bad record_id + ^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type abbreviation "bad" is cyclic: - "bad" = "bad id", - "bad id" contains "bad" + "bad" = "bad record_id", + "bad record_id" contains "bad" +|}] + +type bad = bad alias_id +[%%expect{| +Line 1, characters 0-23: +1 | type bad = bad alias_id + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: The type abbreviation "bad" is cyclic: + "bad" = "bad alias_id", + "bad alias_id" = "bad" |}] @@ -105,11 +185,8 @@ type 'a bad = #{ bad : 'a bad ; u : 'a} Line 1, characters 0-39: 1 | type 'a bad = #{ bad : 'a bad ; u : 'a} ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of 'a bad is any & any - because it is an unboxed record. - But the layout of 'a bad must be representable - because it is the type of record field bad. +Error: The definition of "bad" is recursive without boxing: + "'a bad" contains "'a bad" |}] type 'a bad = { bad : 'a bad ; u : 'a} @@ -117,80 +194,282 @@ type 'a bad = { bad : 'a bad ; u : 'a} type 'a bad = { bad : 'a bad; u : 'a; } |}] -(****************************) -(* A particularly bad error *) - type bad : float64 = #{ bad : bad ; i : int} [%%expect{| Line 1, characters 0-44: 1 | type bad : float64 = #{ bad : bad ; i : int} ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The layout of type "bad" is (((((((((((((((((((((((((((((((((((( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - (float64 & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value - because it is an unboxed record. - But the layout of type "bad" must be a sublayout of float64 - because of the annotation on the declaration of the type bad. +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type bad = #{ a : t ; b : t } +[%%expect{| +type bad = #{ a : t; b : t; } +|}] + +type 'a bad = #{ a : 'a bad } +[%%expect{| +Line 1, characters 0-29: +1 | type 'a bad = #{ a : 'a bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "'a bad" contains "'a bad" +|}] + +type bad = #( s * s ) +and ('a : any) record_id2 = #{ a : 'a } +and s = #{ u : u } +and u = #(int * bad record_id2) +[%%expect{| +Line 1, characters 0-21: +1 | type bad = #( s * s ) + ^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" = "#(s * s)", + "#(s * s)" contains "s", + "s" contains "u", + "u" = "#(int * bad record_id2)", + "#(int * bad record_id2)" contains "bad record_id2", + "bad record_id2" contains "bad" +|}] + +type bad = #( s * s ) +and ('a : any) record_id2 = #{ a : 'a } +and s = #{ u : u } +and u = #(int * bad record_id2) +[%%expect{| +Line 1, characters 0-21: +1 | type bad = #( s * s ) + ^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" = "#(s * s)", + "#(s * s)" contains "s", + "s" contains "u", + "u" = "#(int * bad record_id2)", + "#(int * bad record_id2)" contains "bad record_id2", + "bad record_id2" contains "bad" +|}] + +(* We also check recursive types via modules *) +module rec Bad_rec1 : sig + type t = #( s * s ) + and s = #{ u : Bad_rec2.u } +end = struct + type t = #( s * s ) + and s = #{ u : Bad_rec2.u } +end +and Bad_rec2 : sig + type u = Bad_rec1.t id + and 'a id = 'a +end = struct + type u = Bad_rec1.t id + and 'a id = 'a +end +[%%expect{| +Lines 1-7, characters 0-3: +1 | module rec Bad_rec1 : sig +2 | type t = #( s * s ) +3 | and s = #{ u : Bad_rec2.u } +4 | end = struct +5 | type t = #( s * s ) +6 | and s = #{ u : Bad_rec2.u } +7 | end +Error: The definition of "Bad_rec1.t" is recursive without boxing: + "Bad_rec1.t" = "#(Bad_rec1.s * Bad_rec1.s)", + "#(Bad_rec1.s * Bad_rec1.s)" contains "Bad_rec1.s", + "Bad_rec1.s" contains "Bad_rec2.u", + "Bad_rec2.u" = "Bad_rec1.t Bad_rec2.id", + "Bad_rec1.t Bad_rec2.id" = "Bad_rec1.t" +|}] + +(* When we allow records with elements of unrepresentable layout, this should + still be disallowed. *) +module M : sig + type ('a : any) opaque_id : any +end = struct + type ('a : any) opaque_id = 'a +end +[%%expect{| +module M : sig type ('a : any) opaque_id : any end +|}] +type a = #{ b : b M.opaque_id } +and b = #{ a : a M.opaque_id } +[%%expect{| +Line 1, characters 12-29: +1 | type a = #{ b : b M.opaque_id } + ^^^^^^^^^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of b M.opaque_id is any + because of the definition of opaque_id at line 2, characters 2-33. + But the layout of b M.opaque_id must be representable + because it is the type of record field b. +|}] + +(* Make sure we look through [as] types *) + +type 'a t = #{ x: ('a s as 'm) list ; m : 'm } +and 'b s = #{ x : 'b t } +[%%expect{| +Line 1, characters 0-46: +1 | type 'a t = #{ x: ('a s as 'm) list ; m : 'm } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t" is recursive without boxing: + "'a t" contains "'a s", + "'a s" contains "'a t" +|}] + +type 'a t = #{ x: ('a s as 'm) } +and 'b s = #{ x : 'b t } +[%%expect{| +Line 1, characters 0-32: +1 | type 'a t = #{ x: ('a s as 'm) } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t" is recursive without boxing: + "'a t" contains "'a s", + "'a s" contains "'a t" +|}] + +(***************************************) +(* Singleton recursive unboxed records *) + +type 'a safe = #{ a : 'a } +type x = int safe safe +[%%expect{| +type 'a safe = #{ a : 'a; } +type x = int safe safe +|}] + +type 'a id = 'a +type x = #{ x : x id } +[%%expect{| +type 'a id = 'a +type x = #{ x : x id; } +|}] + +(* CR layouts v7.2: allow bounded repetition of the same type constructor of + unboxed records. *) +type 'a safe = #{ a : 'a } +and x = int safe safe +[%%expect{| +Line 2, characters 0-21: +2 | and x = int safe safe + ^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "x" is recursive without boxing: + "x" = "int safe safe", + "int safe safe" contains "int safe" +|}] + +(* We could allow these, as although they have unguarded recursion, + they are finite size (thanks to the fact that we represent single-field + records as the layout of the field rather than as a singleton product). + However, allowing them makes checking for recursive types more difficult, + and they are uninhabitable anyway. *) + +type bad : value = #{ bad : bad } +[%%expect{| +Line 1, characters 0-33: +1 | type bad : value = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type bad : float64 = #{ bad : bad } +[%%expect{| +Line 1, characters 0-35: +1 | type bad : float64 = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + + +type bad : value = #{ bad : bad } +[%%expect{| +Line 1, characters 0-33: +1 | type bad : value = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type bad = #{ bad : bad } +[%%expect{| +Line 1, characters 0-25: +1 | type bad = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +(* We actually can create singleton recursive unboxed record types, + through recursive modules *) + +module F (X : sig type t end) = struct + type u = #{ u : X.t } +end + +module rec M : sig + type u + type t = u +end = struct + include F(M) + type t = u +end +[%%expect{| +module F : functor (X : sig type t end) -> sig type u = #{ u : X.t; } end +module rec M : sig type u type t = u end +|}] + +module F (X : sig + type u + type t = #{ u : u } + end) = struct + type u = X.t = #{ u : X.u } +end + +module rec M : sig + type u + type t = #{ u : u } +end = struct + include F(M) + type t = #{ u : u } + let rec u = #{ u } +end +[%%expect{| +module F : + functor (X : sig type u type t = #{ u : u; } end) -> + sig type u = X.t = #{ u : X.u; } end +Line 14, characters 14-20: +14 | let rec u = #{ u } + ^^^^^^ +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}] + + +(* This should still error once unboxed records elements need not have a + representable layout *) +module type S = sig + type u : any + type t = #{ a : u ; b : u } +end +module F (X : S) = struct + type u = X.t = #{ a : X.u ; b : X.u} +end + +module rec M : S = struct + include F(M) + type t = #{ a : u ; b : u } + let rec u = #{ u ; u } +end +[%%expect{| +Line 3, characters 14-21: +3 | type t = #{ a : u ; b : u } + ^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of u is any + because of the definition of u at line 2, characters 2-14. + But the layout of u must be representable + because it is the type of record field a. |}] diff --git a/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml b/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml index 8abb07c6569..0c1d36b2e9e 100644 --- a/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml +++ b/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml @@ -25,7 +25,11 @@ type t = { x : t_void; } [@@unboxed] type bad : void = #{ bad : bad } [%%expect{| -type bad = #{ bad : bad; } +Line 1, characters 0-32: +1 | type bad : void = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" |}] type ('a : void) bad = #{ bad : 'a bad ; u : 'a} @@ -33,11 +37,8 @@ type ('a : void) bad = #{ bad : 'a bad ; u : 'a} Line 1, characters 0-49: 1 | type ('a : void) bad = #{ bad : 'a bad ; u : 'a} ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of 'a bad is any & any - because it is an unboxed record. - But the layout of 'a bad must be representable - because it is the type of record field bad. +Error: The definition of "bad" is recursive without boxing: + "'a bad" contains "'a bad" |}] (******************************************************************************) diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml index a0d483357e2..eaa02e604e6 100644 --- a/testsuite/tests/typing-unboxed-types/test.ml +++ b/testsuite/tests/typing-unboxed-types/test.ml @@ -108,17 +108,24 @@ Error: This type cannot be unboxed because its constructor has more than one field. |}];; -(* let rec must be rejected *) +(* This test was made to error by disallowing singleton recursive unboxed types. + We keep it in case these are re-allowed, in which case it should error with: + [This kind of expression is not allowed as right-hand side of "let rec"] *) type t10 : value = A of t10 [@@ocaml.unboxed];; [%%expect{| -type t10 = A of t10 [@@unboxed] +Line 1, characters 0-45: +1 | type t10 : value = A of t10 [@@ocaml.unboxed];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t10" is recursive without boxing: + "t10" contains "t10" |}];; let rec x = A x;; [%%expect{| -Line 1, characters 12-15: +Line 1, characters 14-15: 1 | let rec x = A x;; - ^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" + ^ +Error: This expression has type "t1" but an expression was expected of type + "string" |}];; (* Representation mismatch between module and signature must be rejected *) @@ -352,29 +359,51 @@ in assert (f x = #{ f = 3.14});; - : unit = () |}];; -(* Check for a potential infinite loop in the typing algorithm. *) +(* Check for a potential infinite loop in the typing algorithm. + (This test was made to error upon disallowing singleton recursive [@@unboxed] + types. We keep it around in case these are re-allowed.) *) type 'a t12 = M of 'a t12 [@@ocaml.unboxed];; [%%expect{| -type 'a t12 = M of 'a t12 [@@unboxed] +Line 1, characters 0-43: +1 | type 'a t12 = M of 'a t12 [@@ocaml.unboxed];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t12" is recursive without boxing: + "'a t12" contains "'a t12" |}];; let f (a : int t12 array) = a.(0);; [%%expect{| -val f : int t12 array -> int t12 = +Line 1, characters 15-18: +1 | let f (a : int t12 array) = a.(0);; + ^^^ +Error: Unbound type constructor "t12" +Hint: Did you mean "t1", "t11" or "t2"? |}];; type 'a t12 : value = #{ a : 'a t12 };; [%%expect{| -type 'a t12 = #{ a : 'a t12; } +Line 1, characters 0-37: +1 | type 'a t12 : value = #{ a : 'a t12 };; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t12" is recursive without boxing: + "'a t12" contains "'a t12" |}];; let f (a : int t12 array) = a.(0);; [%%expect{| -val f : int t12 array -> int t12 = +Line 1, characters 15-18: +1 | let f (a : int t12 array) = a.(0);; + ^^^ +Error: Unbound type constructor "t12" +Hint: Did you mean "t1", "t11" or "t2"? |}];; (* Check for another possible loop *) type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];; [%%expect{| -type t13 = A : 'a t12 -> t13 [@@unboxed] +Line 1, characters 17-20: +1 | type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];; + ^^^ +Error: Unbound type constructor "t12" +Hint: Did you mean "t1", "t11", "t13" or "t2"? |}];; diff --git a/testsuite/tests/typing-unboxed/test.ml b/testsuite/tests/typing-unboxed/test.ml index 4c5287e1ab0..ee4da937b43 100644 --- a/testsuite/tests/typing-unboxed/test.ml +++ b/testsuite/tests/typing-unboxed/test.ml @@ -756,7 +756,11 @@ Error: The native code version of the primitive is mandatory (* PR#7424 *) type 'a b = B of 'a b b [@@unboxed];; [%%expect{| -type 'a b = B of 'a b b [@@unboxed] +Line 1, characters 0-35: +1 | type 'a b = B of 'a b b [@@unboxed];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "b" is recursive without boxing: + "'a b" contains "'a b b" |}] diff --git a/typing/ctype.ml b/typing/ctype.ml index 8ac146ae94d..547b8f2d62c 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2116,6 +2116,20 @@ let unbox_once env ty = | Tpoly (ty, _) -> Stepped ty | _ -> Final_result +let contained_without_boxing env ty = + match get_desc ty with + | Tconstr _ -> + begin match unbox_once env ty with + | Stepped ty -> [ty] + | Stepped_record_unboxed_product tys -> tys + | Final_result | Missing _ -> [] + end + | Tunboxed_tuple labeled_tys -> + List.map snd labeled_tys + | Tpoly (ty, _) -> [ty] + | Tvar _ | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil | Tlink _ + | Tsubst _ | Tvariant _ | Tunivar _ | Tpackage _ -> [] + (* We use ty_prev to track the last type for which we found a definition, allowing us to return a type for which a definition was found even if we eventually bottom out at a missing cmi file, or otherwise. *) diff --git a/typing/ctype.mli b/typing/ctype.mli index 6caadd85790..a5d3460cdd8 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -581,6 +581,10 @@ val get_unboxed_type_approximation : Env.t -> type_expr -> type_expr [get_unboxed_type_representation], but doesn't indicate whether the type was fully expanded or not. *) +val contained_without_boxing : Env.t -> type_expr -> type_expr list + (* Return all types that are directly contained without boxing + (or "without indirection" or "flatly") *) + (* Given the row from a variant type, determine if it is immediate. Currently just checks that all constructors have no arguments, doesn't consider void. *) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index c0d44b64740..9f50bca7dc4 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -89,6 +89,7 @@ type error = | Unboxed_mutable_label | Recursive_abbrev of string * Env.t * reaching_type_path | Cycle_in_def of string * Env.t * reaching_type_path + | Unboxed_recursion of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option | Constraint_failed of Env.t * Errortrace.unification_error | Inconsistent_constraint of Env.t * Errortrace.unification_error @@ -2065,6 +2066,110 @@ let check_well_founded_decl ~abs_env env loc path decl to_check = end)} in it.it_type_declaration it (Ctype.generic_instance_declaration decl) +(* We only allow recursion in unboxed product types to occur through boxes, + otherwise the type is uninhabitable and usually also infinite-size. + See [typing-layouts-unboxed-records/recursive.ml]. + + Because [check_well_founded] already ruled out recursion through structural + types, we just look for a cycle in nominal unboxed types ([@@unboxed] types + and unboxed records), tracking the set of seen paths. + + For each group of mutually recursive type declarations, we define the + following "type contains" transitive relation on type expressions: + + 1. Unboxed records and variants defined in the group contain their fields. + + If [type 'a t = #{ ...; lbl : u; ... }], + or [type 'a t = { lbl : u } [@@unboxed]], + or [type 'a t = U of u [@@unboxed]] + is in the recursive group, then ['a t] contains [u]. + + 2. Abbreviations defined in the group contain their expansions. + + If [type 'a t = u] is in the recursive group then ['a t] contains [u]. + + 3. Unboxed tuples contain their components. + + [#(u_1 * ...)] contains all [u_i]. + + 4. Types not in the group contain the parameters indicated by their layout. + + ['a t] contains ['a] if [layout_of 'a] or [any] occurs in ['a t]'s layout. + + For example, if [('a, 'b) t] has layout [layout_of 'a], it may contain + ['a], but not ['b]. If it has layout [any], we must conservatively + consider it to contain both ['a] and ['b]. + + Note: We don't yet have [layout_of], so currently only consider [any]. + + If a path starting from the type expression on the LHS of a declaration + contains two types with the same head type constructor, and that repeated + type is an unboxed record or variant, then the check raises a type error. + + CR layouts v7.2: accept safe types that expand the same path multiple times, + e.g. [type 'a t = #{ a : 'a } and x = int t t], either by using layouts + variables or the algorithm from "Unboxed data constructors - or, how cpp + decides a halting problem." + See https://github.com/ocaml-flambda/flambda-backend/pull/3407. +*) +type step_result = + | Contained of type_expr list + | Expanded_to of type_expr + | Is_cyclic +let check_unboxed_recursion ~abs_env env loc path0 ty0 to_check = + let contained_parameters tyl layout = + (* A type whose layout has [any] could contain all its parameters. + CR layouts v11: update this function for [layout_of] layouts. *) + let rec has_any : Jkind_types.Layout.Const.t -> bool = function + | Any -> true + | Base _ -> false + | Product l -> List.exists has_any l + in + if has_any layout then tyl else [] + in + let step_once parents ty = + match get_desc ty with + | Tconstr (path, tyl, _) -> + if to_check path then + if Path.Set.mem path parents then + Is_cyclic, parents + else + let parents = Path.Set.add path parents in + match Ctype.try_expand_safe_opt env ty with + | ty' -> + Expanded_to ty', parents + | exception Ctype.Cannot_expand -> + Contained (Ctype.contained_without_boxing env ty), parents + else + begin try + (* Determine contained types by layout for decls outside of the + recursive group *) + let jkind = (Env.find_type path env).type_jkind in + let layout = Option.get (Jkind.get_layout jkind) in + Contained (contained_parameters tyl layout), parents + with Not_found | Invalid_argument _ -> + (* Because [to_check path] is false, this decl has already been + typechecked, so it's already in [env] with a constant layout. *) + Misc.fatal_error "Typedecl.check_unboxed_recursion" + end + | _ -> Contained (Ctype.contained_without_boxing env ty), parents + in + let rec visit parents trace ty = + match step_once parents ty with + | Contained tys, parents -> + List.iter (fun ty' -> visit parents (Contains (ty, ty') :: trace) ty') tys + | Expanded_to ty', parents -> + visit parents (Expands_to(ty,ty') :: trace) ty' + | Is_cyclic, _ -> + raise (Error (loc, Unboxed_recursion (path0, abs_env, List.rev trace))) + in + Ctype.wrap_trace_gadt_instances env (visit Path.Set.empty []) ty0 + +let check_unboxed_recursion_decl ~abs_env env loc path decl to_check = + let decl = Ctype.generic_instance_declaration decl in + let ty = Btype.newgenty (Tconstr (path, decl.type_params, ref Mnil)) in + check_unboxed_recursion ~abs_env env loc (Path.name path) ty to_check + (* Check for non-regular abbreviations; an abbreviation [type 'a t = ...] is non-regular if the expansion of [...] contains instances [ty t] where [ty] is not equal to ['a]. @@ -2353,6 +2458,11 @@ let transl_type_decl env rec_flag sdecl_list = decls; List.iter (fun (tdecl, _shape) -> check_abbrev_regularity ~abs_env new_env id_loc_list to_check tdecl) tdecls; + List.iter (fun (id, decl) -> + check_unboxed_recursion_decl ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) + decl to_check) + decls; (* Now that we've ruled out ill-formed types, we can perform the delayed jkind checks *) List.iter (fun (checks,loc) -> @@ -3438,6 +3548,7 @@ let check_recmod_typedecl env loc recmod_ids path decl = (path, decl) is the type declaration to be checked. *) let to_check path = Path.exists_free recmod_ids path in check_well_founded_decl ~abs_env:env env loc path decl to_check; + check_unboxed_recursion_decl ~abs_env:env env loc path decl to_check; check_regularity ~abs_env:env env loc path decl to_check; (* additional coherence check, as one might build an incoherent signature, and use it to build an incoherent module, cf. #7851 *) @@ -3492,8 +3603,10 @@ module Reaching_path = struct (* Simplify a reaching path before showing it in error messages. *) let simplify path = + let is_tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false in let rec simplify : t -> t = function - | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + | Contains (ty1, _ty2) :: Contains (ty2', ty3) :: rest + when not (is_tconstr ty2') -> (* If t1 contains t2 and t2 contains t3, then t1 contains t3 and we don't need to show t2. *) simplify (Contains (ty1, ty3) :: rest) @@ -3581,6 +3694,14 @@ let report_error ppf = function fprintf ppf "@[The definition of %a contains a cycle%a@]" Style.inline_code s Reaching_path.pp_colon reaching_path + | Unboxed_recursion (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %a is recursive without boxing%a@]" + Style.inline_code s + Reaching_path.pp_colon reaching_path | Definition_mismatch (ty, _env, None) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" "This variant or record definition" "does not match that of type" diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 13693ebd5a7..1a1555a9d1a 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -125,6 +125,7 @@ type error = | Unboxed_mutable_label | Recursive_abbrev of string * Env.t * reaching_type_path | Cycle_in_def of string * Env.t * reaching_type_path + | Unboxed_recursion of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option | Constraint_failed of Env.t * Errortrace.unification_error | Inconsistent_constraint of Env.t * Errortrace.unification_error From e1e4fb81c1921e41ec4354ce0b72a43c9db09aa8 Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Fri, 10 Jan 2025 16:15:48 +0000 Subject: [PATCH 30/30] `portable` lazy allows `nonportable` thunk (#3436) * portable lazy allows nonportable thunk * add documentation * improve documentation * add examples * improve comments in test * say "not stronger" --- jane/doc/extensions/modes/reference.md | 42 ++++++++++++++++++++++++++ testsuite/tests/typing-modes/lazy.ml | 27 +++++------------ typing/typecore.ml | 3 ++ 3 files changed, 53 insertions(+), 19 deletions(-) create mode 100644 jane/doc/extensions/modes/reference.md diff --git a/jane/doc/extensions/modes/reference.md b/jane/doc/extensions/modes/reference.md new file mode 100644 index 00000000000..0df097c5056 --- /dev/null +++ b/jane/doc/extensions/modes/reference.md @@ -0,0 +1,42 @@ +The goal of this document is to be a reasonably complete reference to the mode system in +OCaml. + + + +The mode system in the compiler tracks various properties of values, so that certain +performance-enhancing operations can be performed safely. For example: +- Locality tracks escaping. See [the local allocations reference](../local/reference.md) +- Uniqueness and linearity tracks aliasing. See [the uniqueness reference](../uniqueness/reference.md) +- Portability and contention tracks inter-thread sharing. + + +# Lazy +`lazy e` contains a thunk that evaluates `e`, as well as a mutable cell to store the +result of `e`. Upon construction, the mode of `lazy e` cannot be stronger than `e`. For +example, if `e` is `nonportable`, then `lazy e` cannot be `portable`. Upon destruction +(forcing a lazy value), the result cannot be stronger than the mode of lazy value. For +example, forcing a `nonportable` lazy value cannot give a `portable` result. Additionally, +forcing a lazy value involves accessing the mutable cell and thus requires the lazy value +to be `uncontended`. + +Currently, the above rules don't apply to the locality axis, because both the result and +the lazy value are heap-allocated, so they are always `global`. + +Additionally, upon construction, the comonadic fragment of `lazy e` cannot be stronger +than the thunk. The thunk is checked as `fun () -> e`, potentially closing over variables, +which weakens its comonadic fragment. This rule doesn't apply to several axes: +- The thunk is always heap-allocated so always `global`. +- Since the thunk is only evaluated if the lazy value is `uncontended`, one can construct +a lazy value at `portable` even if the thunk is `nonportable` (e.g., closing over +`uncontended` or `nonportable` values). For example, the following is allowed: +```ocaml +let r = ref 0 in +let l @ portable = lazy (r := 42) in +``` +- Since the thunk runs at most once even if the lazy value is forced multiple times, one +can construct the lazy value at `many` even if the thunk is `once` (e.g., closing over +`unique` or `once` values). For example, the following is allowed: +```ocaml +let r = { x = 0 } in +let l @ many = lazy (overwrite_ r with { x = 42 }) +``` diff --git a/testsuite/tests/typing-modes/lazy.ml b/testsuite/tests/typing-modes/lazy.ml index 1802de84380..fd834b214e5 100644 --- a/testsuite/tests/typing-modes/lazy.ml +++ b/testsuite/tests/typing-modes/lazy.ml @@ -43,8 +43,7 @@ let foo (x @ local) = val foo : local_ 'a lazy_t -> 'a = |}] -(* one can construct portable lazy, if both the thunk and the result are - portable *) +(* one can construct [portable] lazy only if the result is [portable] *) let foo () = let l = lazy (let x @ nonportable = fun x -> x in x) in use_portable l @@ -55,32 +54,21 @@ Line 3, characters 17-18: Error: This value is "nonportable" but expected to be "portable". |}] +(* thunk is evaluated only when [uncontended] lazy is forced, so the thunk can be + [nonportable] even if the lazy is [portable]. *) let foo (x @ nonportable) = let l = lazy (let _ = x in ()) in use_portable l [%%expect{| -Line 3, characters 17-18: -3 | use_portable l - ^ -Error: This value is "nonportable" but expected to be "portable". -|}] - -let foo (x @ portable) = - let l = lazy (let _ = x in let y = fun () -> () in y) in - use_portable l -[%%expect{| -val foo : 'a @ portable -> unit = +val foo : 'a -> unit = |}] -(* inside a portable lazy, things are available as contended *) +(* For the same reason, [portable] lazy can close over things at [uncontended]. *) let foo (x @ uncontended) = - let l @ portable = lazy ( let x' @ uncontended = x in ()) in + let l @ portable = lazy ( let _x @ uncontended = x in ()) in use_portable l [%%expect{| -Line 2, characters 53-54: -2 | let l @ portable = lazy ( let x' @ uncontended = x in ()) in - ^ -Error: This value is "contended" but expected to be "uncontended". +val foo : 'a -> unit = |}] (* Portable lazy gives portable result *) @@ -91,6 +79,7 @@ let foo (x @ portable) = val foo : 'a lazy_t @ portable -> unit = |}] +(* Nonportable lazy gives nonportable result *) let foo (x @ nonportable) = match x with | lazy r -> use_portable x diff --git a/typing/typecore.ml b/typing/typecore.ml index 6f0d087af73..307a968fd7f 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -551,6 +551,9 @@ let mode_lazy expected_mode = (* The thunk is evaluated only once, so we only require it to be [once], even if the [lazy] is [many]. *) |> Value.join_with (Comonadic Linearity) Linearity.Const.Once + (* The thunk is evaluated only when the [lazy] is [uncontended], so we only require it + to be [nonportable], even if the [lazy] is [portable]. *) + |> Value.join_with (Comonadic Portability) Portability.Const.Nonportable in {expected_mode with locality_context = Some Lazy }, closure_mode