diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 3766aa0315d..ab6fda6573e 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -158,6 +158,7 @@ let preserve_tailcall_for_prim = function | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pufloatfield _ | Psetufloatfield _ | Pmixedfield _ | Psetmixedfield _ | Pmake_unboxed_product _ | Punboxed_product_field _ + | Parray_element_size_in_bytes _ | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat _ @@ -415,6 +416,8 @@ let comp_primitive stack_info p sz args = | Pcompare_bints bi -> comp_bint_primitive bi "compare" args | Pfield (n, _ptr, _sem) -> Kgetfield n | Punboxed_product_field (n, _layouts) -> Kgetfield n + | Parray_element_size_in_bytes _array_kind -> + Kconst (Const_base (Const_int (Sys.word_size / 8))) | Pfield_computed _sem -> Kgetvectitem | Psetfield(n, _ptr, _init) -> Ksetfield n | Psetfield_computed(_ptr, _init) -> Ksetvectitem @@ -685,7 +688,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 +707,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 +716,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. *) @@ -1011,6 +1020,54 @@ 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/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/lambda/lambda.ml b/lambda/lambda.ml index a151ee51b1d..2e3061cfe95 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 = @@ -149,6 +153,7 @@ type primitive = (* Unboxed products *) | Pmake_unboxed_product of layout list | Punboxed_product_field of int * layout list + | Parray_element_size_in_bytes of array_kind (* Context switches *) | Prunstack | Pperform @@ -189,9 +194,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 +952,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 +1831,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 _ @@ -1928,7 +1940,8 @@ let primitive_may_allocate : primitive -> locality_mode option = function | Patomic_cas | Patomic_fetch_add | Pdls_get - | Preinterpret_unboxed_int64_as_tagged_int63 -> None + | Preinterpret_unboxed_int64_as_tagged_int63 + | Parray_element_size_in_bytes _ -> None | Preinterpret_tagged_int63_as_unboxed_int64 -> if !Clflags.native_code then None else @@ -2093,7 +2106,8 @@ let primitive_can_raise prim = | Patomic_cas | Patomic_fetch_add | Patomic_load _ -> false | Prunstack | Pperform | Presume | Preperform -> true (* XXX! *) | Pdls_get | Ppoll | Preinterpret_tagged_int63_as_unboxed_int64 - | Preinterpret_unboxed_int64_as_tagged_int63 -> + | Preinterpret_unboxed_int64_as_tagged_int63 + | Parray_element_size_in_bytes _ -> false let constant_layout: constant -> layout = function @@ -2205,6 +2219,7 @@ let primitive_result_layout (p : primitive) = | Pfield _ | Pfield_computed _ -> layout_value_field | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field) | Pmake_unboxed_product layouts -> layout_unboxed_product layouts + | Parray_element_size_in_bytes _ -> layout_int | Pfloatfield _ -> layout_boxed_float Boxed_float64 | Pfloatoffloat32 _ -> layout_boxed_float Boxed_float64 | Pfloat32offloat _ -> layout_boxed_float Boxed_float32 @@ -2388,6 +2403,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 +2509,47 @@ let rec try_to_find_location lam = let try_to_find_debuginfo lam = Debuginfo.from_location (try_to_find_location lam) + +(* The "count_initializers_*" functions count the number of individual + components in an initializer for the corresponding array kind _after_ + unarization. These are used to implement the "%array_element_size_in_bytes" + primitives for products, as each such component takes a full word in product + arrays. *) +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..1f2a613c49c 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 *) @@ -137,6 +141,7 @@ type primitive = | Pmake_unboxed_product of layout list | Punboxed_product_field of int * (layout list) (* the [layout list] is the layout of the whole product *) + | Parray_element_size_in_bytes of array_kind (* Context switches *) | Prunstack | Pperform @@ -178,15 +183,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 +925,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 +1171,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 +1191,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..b46fc2d9b43 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -609,6 +609,8 @@ let primitive ppf = function fprintf ppf "unboxed_product_field %d #(%a)" n (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ") (layout' false)) layouts + | Parray_element_size_in_bytes ak -> + fprintf ppf "array_element_size_in_bytes (%s)" (array_kind ak) | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" @@ -668,14 +670,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 @@ -947,6 +955,7 @@ let name_of_primitive = function | Pduprecord _ -> "Pduprecord" | Pmake_unboxed_product _ -> "Pmake_unboxed_product" | Punboxed_product_field _ -> "Punboxed_product_field" + | Parray_element_size_in_bytes _ -> "Parray_element_size_in_bytes" | Pccall _ -> "Pccall" | Praise _ -> "Praise" | Psequand -> "Psequand" 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/tmc.ml b/lambda/tmc.ml index 4a65037e891..98be0d77751 100644 --- a/lambda/tmc.ml +++ b/lambda/tmc.ml @@ -923,6 +923,7 @@ let rec choice ctx t = (* nor unboxed products *) | Pmake_unboxed_product _ | Punboxed_product_field _ + | Parray_element_size_in_bytes _ | Pobj_dup | Pobj_magic _ diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 109651c043c..c425190db92 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,26 @@ 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); + | "%array_element_size_in_bytes" -> + (* The array kind will be filled in later *) + Primitive (Parray_element_size_in_bytes Pgenarray, 1) | "%obj_size" -> Primitive ((Parraylength Pgenarray), 1) | "%obj_field" -> Primitive ((Parrayrefu (Pgenarray_ref mode, Ptagged_int_index, Mutable)), 2) | "%obj_set_field" -> @@ -1229,19 +1257,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 +1298,19 @@ 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 (Parray_element_size_in_bytes _, arity), p1 :: _ -> ( + let array_kind = + array_type_kind ~elt_sort:None env (to_location loc) p1 + in + Some (Primitive (Parray_element_size_in_bytes array_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 +1790,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 _ @@ -1767,6 +1824,7 @@ let lambda_primitive_needs_event_after = function | Pgetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ | Pmakeufloatblock _ | Pmakemixedblock _ | Pmake_unboxed_product _ | Punboxed_product_field _ + | Parray_element_size_in_bytes _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _ | Pufloatfield _ | Psetufloatfield _ | Pmixedfield _ | Psetmixedfield _ @@ -1783,7 +1841,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 +1915,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/lambda/value_rec_compiler.ml b/lambda/value_rec_compiler.ml index be935829918..4d67ea0664d 100644 --- a/lambda/value_rec_compiler.ml +++ b/lambda/value_rec_compiler.ml @@ -368,7 +368,8 @@ let compute_static_size lam = | Punboxed_float32_array_set_128 _ | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _ - | Punboxed_nativeint_array_set_128 _ -> + | Punboxed_nativeint_array_set_128 _ + | Parray_element_size_in_bytes _ -> Constant | Pmakeufloatblock (_, _) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 00f1f447c81..598d98bd3ae 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 (_, _) @@ -1045,9 +1044,10 @@ let close_primitive acc env ~let_bound_ids_with_kinds named | Punbox_vector _ | Pbox_vector (_, _) | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ - | Punboxed_product_field _ | Pget_header _ | Prunstack | Pperform - | Presume | Preperform | Patomic_exchange | Patomic_compare_exchange - | Patomic_cas | Patomic_fetch_add | Pdls_get | Ppoll | Patomic_load _ + | Punboxed_product_field _ | Parray_element_size_in_bytes _ + | Pget_header _ | Prunstack | Pperform | Presume | Preperform + | Patomic_exchange | Patomic_compare_exchange | Patomic_cas + | Patomic_fetch_add | Pdls_get | Ppoll | Patomic_load _ | Preinterpret_tagged_int63_as_unboxed_int64 | Preinterpret_unboxed_int64_as_tagged_int63 -> (* Inconsistent with outer match *) 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 a7a1494fa94..dac7ec7cb37 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 @@ -1336,6 +1363,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) let mutability = Mutability.from_lambda mutability in [Variadic (Make_block (Values (tag, shape), mutability, mode), args)] | Pmake_unboxed_product layouts, _ -> + (* CR mshinwell: this should check the unarized lengths of [layouts] and + [args] (like [Parray_element_size_in_bytes] below) *) if List.compare_lengths layouts args <> 0 then Misc.fatal_errorf "Pmake_unboxed_product: expected %d arguments, got %d" @@ -1365,6 +1394,26 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) |> Array.to_list in List.map (fun arg : H.expr_primitive -> Simple arg) projected_args + | Parray_element_size_in_bytes array_kind, [_witness] -> + (* This is implemented as a unary primitive, but from our point of view it's + actually nullary. *) + let num_bytes = + match array_kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray -> 8 + | Punboxedfloatarray Unboxed_float32 -> + (* float32# arrays are packed *) + 4 + | Punboxedfloatarray Unboxed_float64 -> 8 + | Punboxedintarray Unboxed_int32 -> + (* int32# arrays are packed *) + 4 + | Punboxedintarray (Unboxed_int64 | Unboxed_nativeint) -> 8 + | Punboxedvectorarray Unboxed_vec128 -> 16 + | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> + (* All elements of unboxed product arrays are currently 8 bytes wide. *) + L.count_initializers_array_kind array_kind * 8 + in + [Simple (Simple.const_int (Targetint_31_63.of_int num_bytes))] | Pmakefloatblock (mutability, mode), _ -> let args = List.flatten args in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in @@ -1431,10 +1480,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]] -> @@ -1976,6 +2025,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]] -> @@ -2345,8 +2396,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 _ ), _ ) -> @@ -2377,7 +2427,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Punbox_int _ | Pbox_int _ | Punboxed_product_field _ | Pget_header _ | Pufloatfield _ | Patomic_load _ | Pmixedfield _ | Preinterpret_unboxed_int64_as_tagged_int63 - | Preinterpret_tagged_int63_as_unboxed_int64 ), + | Preinterpret_tagged_int63_as_unboxed_int64 + | Parray_element_size_in_bytes _ ), ([] | _ :: _ :: _ | [([] | _ :: _ :: _)]) ) -> Misc.fatal_errorf "Closure_conversion.convert_primitive: Wrong arity for unary primitive \ 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/otherlibs/stdlib_alpha/capsule.ml b/otherlibs/stdlib_alpha/capsule.ml index a760d466109..2e095abcd1a 100644 --- a/otherlibs/stdlib_alpha/capsule.ml +++ b/otherlibs/stdlib_alpha/capsule.ml @@ -12,6 +12,12 @@ (* *) (**************************************************************************) +module Global = struct + type 'a t = { global : 'a @@ global } [@@unboxed] +end + +open Global + (* Like [int Stdlib.Atomic.t], but [portable]. *) module A = struct type t : value mod portable uncontended @@ -29,14 +35,14 @@ end external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool @@ portable = "%equal" module Name : sig - type 'k t : value mod global portable many uncontended unique - type packed = P : 'k t -> packed + type 'k t : value mod external_ global portable many uncontended unique + type packed = P : 'k t -> packed [@@unboxed] val make : unit -> packed @@ portable val equality_witness : 'k1 t -> 'k2 t -> ('k1, 'k2) Type.eq option @@ portable end = struct type 'k t = int - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] let ctr = A.make 0 let make () = P (A.fetch_and_add ctr 1) @@ -50,9 +56,9 @@ end module Access : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t : value mod global portable many unique + type 'k t : value mod external_ global portable many unique - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] (* Can break soundness. *) val unsafe_mk : unit -> 'k t @@ portable @@ -63,7 +69,7 @@ end = struct type 'k t = T : dummy t - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] external unsafe_rebrand : 'k t -> 'j t @@ portable = "%identity" @@ -83,9 +89,9 @@ let initial = Access.unsafe_mk () module Password : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t : value mod portable many unique uncontended + type 'k t : value mod external_ portable many unique uncontended - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] (* Can break the soundness of the API. *) val unsafe_mk : 'k Name.t -> 'k t @@ portable @@ -94,7 +100,7 @@ module Password : sig module Shared : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t + type 'k t : value mod external_ portable many unique uncontended (* Can break the soundness of the API. *) val unsafe_mk : 'k Name.t -> 'k t @@ portable @@ -105,7 +111,7 @@ module Password : sig end = struct type 'k t = 'k Name.t - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] let unsafe_mk name = name let name t = t @@ -132,17 +138,21 @@ module Data = struct exception Encapsulated : 'k Name.t * (exn, 'k) t -> exn - external unsafe_mk : 'a -> ('a, 'k) t @@ portable = "%identity" + external unsafe_mk : ('a[@local_opt]) -> (('a, 'k) t[@local_opt]) @@ portable = "%identity" - external unsafe_get : ('a, 'k) t -> 'a @@ portable = "%identity" + external unsafe_get : (('a, 'k) t[@local_opt]) -> ('a[@local_opt]) @@ portable = "%identity" let wrap _ t = unsafe_mk t + let wrap_local _ t = exclave_ unsafe_mk t let unwrap _ t = unsafe_get t + let unwrap_local _ t = exclave_ unsafe_get t let unwrap_shared _ t = unsafe_get t + let unwrap_shared_local _ t = exclave_ unsafe_get t let create f = unsafe_mk (f ()) + let create_local f = exclave_ 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 @@ -159,62 +169,112 @@ module Data = struct | res -> unsafe_mk res | exception exn -> reraise_encapsulated pw exn + let map_local pw f t = exclave_ + let v = unsafe_get t in + match f v with + | res -> unsafe_mk res + | exception exn -> reraise_encapsulated pw exn + let fst t = let t1, _ = unsafe_get t in unsafe_mk t1 + let fst_local t = exclave_ + let t1, _ = unsafe_get t in + unsafe_mk t1 + let snd t = let _, t2 = unsafe_get t in unsafe_mk t2 + let snd_local t = exclave_ + let _, t2 = unsafe_get t in + unsafe_mk t2 + let both t1 t2 = unsafe_mk (unsafe_get t1, unsafe_get t2) + let both_local t1 t2 = exclave_ unsafe_mk (unsafe_get t1, unsafe_get t2) let extract pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated pw exn + let extract_local pw f t = exclave_ + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated pw exn + let inject = unsafe_mk + let inject_local = unsafe_mk let project = unsafe_get + let project_local = unsafe_get let bind pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated pw exn + let bind_local pw f t = exclave_ + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated pw exn + let iter pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated pw exn + let iter_local pw f t = + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated pw exn + let map_shared pw f t = let v = unsafe_get t in match f v with | res -> unsafe_mk res | exception exn -> reraise_encapsulated_shared pw exn + let map_shared_local pw f t = exclave_ + let v = unsafe_get t in + match f v with + | res -> unsafe_mk res + | exception exn -> reraise_encapsulated_shared pw exn + + let extract_shared pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated_shared pw exn + let extract_shared_local pw f t = exclave_ + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated_shared pw exn + end exception Encapsulated = Data.Encapsulated -let access (type k) (pw : k Password.t) f = +let access_local (type k) (pw : k Password.t) f = exclave_ let c : k Access.t = Access.unsafe_mk () in match f c with | res -> res | exception exn -> Data.reraise_encapsulated pw exn -let access_shared (type k) (pw : k Password.Shared.t) f = +let access pw f = + (access_local pw (fun access -> { global = f access })).global + +let access_shared_local (type k) (pw : k Password.Shared.t) f = exclave_ let c : k Access.t = Access.unsafe_mk () in match f c with | res -> res | exception exn -> Data.reraise_encapsulated_shared pw exn +let access_shared pw f = + (access_shared_local pw (fun access -> { global = f access })).global + (* Like [Stdlib.Mutex], but [portable]. *) module M = struct type t : value mod portable uncontended @@ -381,23 +441,6 @@ let create_with_rwlock () = let (P name) = Name.make () in Rwlock.P { name; rwlock = Rw.create (); poisoned = false } -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 = - 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 - | 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 @@ -408,10 +451,4 @@ let with_password_local f = exclave_ | 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 3373b448e94..31cdfbebf6d 100644 --- a/otherlibs/stdlib_alpha/capsule.mli +++ b/otherlibs/stdlib_alpha/capsule.mli @@ -58,14 +58,14 @@ module Access : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t : value mod global portable many unique + type 'k t : value mod external_ global portable many unique (** ['k t] represents access to the current capsule, allowing wraping and unwraping [Data.t] values. An [uncontended] ['k t] indicates that ['k] is the current capsule. A [shared] ['k t] indicates that ['k] is the current capsule but that it may be shared with other domains. *) - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] (** [packed] is the type of access to some unknown capsule. Unpacking one provides a ['k t] together with a fresh existential type brand for ['k]. *) @@ -91,9 +91,9 @@ val initial : initial Access.t (** Passwords represent permission to get access to a capsule. *) module Password : sig - (* CR layouts v5: this should have layout [void], but - [void] can't be used for function argument and return types yet. *) - type 'k t : value mod portable many unique uncontended + (* CR layouts v5: this should have layout [void], but + [void] can't be used for function argument and return types yet. *) + type 'k t : value mod external_ portable many unique uncontended (** ['k t] is the type of "passwords" representing permission for the current fiber to have [uncontended] access to the capsule ['k]. They are only ever avilable locally, so that they cannot move @@ -104,7 +104,7 @@ 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 + type packed = P : 'k t -> packed [@@unboxed] (** [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]. *) @@ -115,7 +115,7 @@ module Password : sig (** Shared passwords represent permission to get shared access to a capsule *) module Shared : sig - type 'k t + type 'k t : value mod external_ portable many unique uncontended (** ['k t] is the type of "shared passwords" representing permission for the current fiber to have [shared] access to the capsule ['k]. They are only ever avilable locally, so that they cannot @@ -137,21 +137,39 @@ end val access : 'k Password.t @ local -> ('k Access.t -> 'a @ portable contended) @ local portable - -> 'a @ contended + -> 'a @ portable contended @@ portable (** [access p f] runs [f] within the capsule ['k], providing it with an {!Access.t} for ['k]. The result is within ['k] so it must be [portable] and it is marked [contended]. *) +val access_local : + 'k Password.t @ local + -> ('k Access.t -> 'a @ local portable contended) @ local portable + -> 'a @ local portable contended + @@ portable +(** [access_local p f] runs [f] within the capsule ['k], providing it with + an {!Access.t} for ['k]. The result is within ['k] so it must be + [portable] and it is marked [contended]. *) + val access_shared : 'k Password.Shared.t @ local -> ('k Access.t @ shared -> 'a @ portable contended) @ local portable - -> 'a @ contended + -> 'a @ portable contended @@ portable (** [shared_access p f] runs [f] within the capsule ['k], providing it with a shared {!Access.t} for ['k]. The result is within ['k] so it must be [portable] and it is marked [contended]. *) +val access_shared_local : + 'k Password.Shared.t @ local + -> ('k Access.t @ shared -> 'a @ local portable contended) @ local portable + -> 'a @ local portable contended + @@ portable +(** [shared_access_local p f] runs [f] within the capsule ['k], providing it + with a shared {!Access.t} for ['k]. The result is within ['k] so it + must be [portable] and it is marked [contended]. *) + (** Does *not* require runtime5. In runtime4, implemented as a no-op, hence does not provide mutual exclusion between systhreads. *) module Mutex : sig @@ -244,9 +262,9 @@ end (** Requires runtime5. *) module Condition : sig - type 'k t : value mod portable uncontended - (** ['k t] is the type of a condition variable associated with the capsule ['k]. - This condition may only be used with the matching ['k Mutex.t]. *) + type 'k t : value mod portable uncontended + (** ['k t] is the type of a condition variable associated with the capsule ['k]. + This condition may only be used with the matching ['k Mutex.t]. *) val create : unit -> 'k t @@ portable (** [create ()] creates and returns a new condition variable. @@ -287,24 +305,40 @@ module Data : sig type ('a, 'k) t : value mod portable uncontended (** [('a, 'k) t] is the type of ['a]s within the capsule ['k]. It - can be passed between domains. Operations on [('a, 'k) t] - require a ['k Password.t], created from the ['k Mutex.t]. *) + can be passed between domains. Operations on [('a, 'k) t] + require a ['k Password.t], created from the ['k Mutex.t]. *) val wrap : 'k Access.t @ local shared -> 'a -> ('a, 'k) t @@ portable - (** [wrap c v] is a pointer to a value [v] from the current - capsule. *) + (** [wrap c v] is a pointer to a value [v] from the + current capsule. *) + + val wrap_local : + 'k Access.t @ local shared + -> 'a @ local + -> ('a, 'k) t @ local + @@ portable + (** [wrap_local c v] is a pointer to a value [v] from the + current capsule. *) val unwrap : 'k Access.t @ local -> ('a, 'k) t -> 'a @@ portable - (** [unwrap c t] returns the value of [t] which is from the current - capsule. *) + (** [unwrap c t] returns the value of [t] which is from the + current capsule. *) + + val unwrap_local : + 'k Access.t @ local + -> ('a, 'k) t @ local + -> 'a @ local + @@ portable + (** [unwrap_local c t] returns the value of [t] which is from the + current capsule. *) val unwrap_shared : ('a : value mod portable) 'k. @@ -312,15 +346,31 @@ module Data : sig -> ('a, 'k) t -> 'a @ shared @@ portable - (** [unwrap_shared c t] returns the shared value of [t] which is - from the current capsule. *) + (** [unwrap_shared c t] returns the shared value of [t] which is from + the current capsule. *) + + val unwrap_shared_local : + ('a : value mod portable) 'k. + 'k Access.t @ local shared + -> ('a, 'k) t @ local + -> 'a @ local shared + @@ portable + (** [unwrap_shared_local c t] returns the shared value of [t] which is from + the current capsule. *) val create : (unit -> 'a) @ local portable -> ('a, 'k) t @@ portable - (** [create f] runs [f] within the capsule ['k] and creates - a pointer to the result of [f]. *) + (** [create f] runs [f] within the capsule ['k] and creates a pointer to + the result of [f]. *) + + val create_local : + (unit -> 'a @ local) @ local portable + -> ('a, 'k) t @ local + @@ portable + (** [create_local f] runs [f] within the capsule ['k] and creates a pointer to + the result of [f]. *) val map : 'k Password.t @ local @@ -331,6 +381,15 @@ module Data : sig (** [map p f t] applies [f] to the value of [p] within the capsule ['k], creating a pointer to the result. *) + val map_local : + 'k Password.t @ local + -> ('a @ local -> 'b @ local) @ local portable + -> ('a, 'k) t @ local + -> ('b, 'k) t @ local + @@ portable + (** [map_local p f t] applies [f] to the value of [p] within the capsule ['k], + creating a pointer to the result. *) + val both : ('a, 'k) t -> ('b, 'k) t @@ -338,18 +397,37 @@ module Data : sig @@ portable (** [both t1 t2] is a pointer to a pair of the values of [t1] and [t2]. *) + val both_local : + ('a, 'k) t @ local + -> ('b, 'k) t @ local + -> ('a * 'b, 'k) t @ local + @@ portable + (** [both_local t1 t2] is a pointer to a pair of the values of [t1] and [t2]. *) + val fst : ('a * 'b, 'k) t -> ('a, 'k) t @@ portable (** [fst t] gives a pointer to the first value inside [t] *) + val fst_local : + ('a * 'b, 'k) t @ local + -> ('a, 'k) t @ local + @@ portable + (** [fst_local t] gives a pointer to the first value inside [t] *) + val snd : ('a * 'b, 'k) t -> ('b, 'k) t @@ portable (** [snd t] gives a pointer to the second value inside [t] *) + val snd_local : + ('a * 'b, 'k) t @ local + -> ('b, 'k) t @ local + @@ portable + (** [snd_local t] gives a pointer to the second value inside [t] *) + val extract : 'k Password.t @ local -> ('a -> 'b @ portable contended) @ local portable @@ -360,6 +438,16 @@ module Data : sig the capsule ['k] and returns the result. The result is within ['k] so it must be [portable] and it is marked [contended]. *) + val extract_local : + 'k Password.t @ local + -> ('a @ local -> 'b @ local portable contended) @ local portable + -> ('a, 'k) t @ local + -> 'b @ local portable contended + @@ portable + (** [extract_local p f t] applies [f] to the value of [t] within + the capsule ['k] and returns the result. The result is within ['k] + so it must be [portable] and it is marked [contended]. *) + val inject : ('a : value mod uncontended) 'k. 'a @ portable -> ('a, 'k) t @@ -367,6 +455,13 @@ module Data : sig (** [inject v] is a pointer to an immutable value [v] injected into the capsule ['k]. *) + val inject_local : + ('a : value mod uncontended) 'k. + 'a @ local portable -> ('a, 'k) t @ local + @@ portable + (** [inject_local v] is a pointer to an immutable value [v] injected + into the capsule ['k]. *) + val project : ('a : value mod portable) 'k. ('a, 'k) t -> 'a @ contended @@ -374,6 +469,13 @@ module Data : sig (** [project t] returns the value of [t]. The result is within ['k] so it must be [portable] and it is marked [contended]. *) + val project_local : + ('a : value mod portable) 'k. + ('a, 'k) t @ local -> 'a @ local contended + @@ portable + (** [project_local t] returns the value of [t]. The result is within + ['k] so it must be [portable] and it is marked [contended]. *) + val bind : 'k Password.t @ local -> ('a -> ('b, 'j) t) @ local portable @@ -382,6 +484,14 @@ module Data : sig @@ portable (** [bind f t] is [project (map f t)]. *) + val bind_local : + 'k Password.t @ local + -> ('a @ local -> ('b, 'j) t @ local) @ local portable + -> ('a, 'k) t @ local + -> ('b, 'j) t @ local + @@ portable + (** [bind_local f t] is [project_local (map_local f t)]. *) + val iter : 'k Password.t @ local -> ('a -> unit) @ local portable @@ -390,6 +500,14 @@ module Data : sig @@ portable (** [iter] is [extract] with result type specialized to [unit]. *) + val iter_local : + 'k Password.t @ local + -> ('a @ local -> unit) @ local portable + -> ('a, 'k) t @ local + -> unit + @@ portable + (** [iter_local] is [extract_local] with result type specialized to [unit]. *) + val map_shared : ('a : value mod portable) 'b 'k. 'k Password.Shared.t @ local @@ -401,6 +519,17 @@ module Data : sig creating a pointer to the result. Since [nonportable] functions may enclose [uncontended] (and thus write) access to data, ['a] must cross [portability] *) + val map_shared_local : + ('a : value mod portable) 'b 'k. + 'k Password.Shared.t @ local + -> ('a @ local shared -> 'b @ local) @ local portable + -> ('a, 'k) t @ local + -> ('b, 'k) t @ local + @@ portable + (** [map_shared_local p f t] applies [f] to the shared parts of [p] within the capsule ['k], + creating a pointer to the result. Since [nonportable] functions may enclose + [uncontended] (and thus write) access to data, ['a] must cross [portability] *) + val extract_shared : ('a : value mod portable) 'b 'k. 'k Password.Shared.t @ local @@ -408,7 +537,20 @@ module Data : sig -> ('a, 'k) t -> 'b @ portable contended @@ portable - (** [extract p f t] applies [f] to the value of [t] within + (** [extract_shared p f t] applies [f] to the value of [t] within + the capsule ['k] and returns the result. The result is within ['k] + so it must be [portable] and it is marked [contended]. Since [nonportable] + functions may enclose [uncontended] (and thus write) access to data, + ['a] must cross [portability] *) + + val extract_shared_local : + ('a : value mod portable) 'b 'k. + 'k Password.Shared.t @ local + -> ('a @ local shared -> 'b @ local portable contended) @ local portable + -> ('a, 'k) t @ local + -> 'b @ local portable contended + @@ portable + (** [extract_shared_local p f t] applies [f] to the value of [t] within the capsule ['k] and returns the result. The result is within ['k] so it must be [portable] and it is marked [contended]. Since [nonportable] functions may enclose [uncontended] (and thus write) access to data, @@ -421,27 +563,14 @@ 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 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 -> 'a @@ portable +(** [with_password f] creates a fresh capsule and applies [f] with the associated [password]. -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. *) + [with_password] destroys the capsule, 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 -> 'a @ local @@ portable +(** See [with_password]. -val with_password_local : (Password.packed @ local -> 'a @ local) @ local portable -> 'a @ local @@ portable -(** See [with_password]. *) + If [f] returns normally, note that the capsule is not destroyed, and locality still enforces + that the password cannot escape. *) diff --git a/runtime/alloc.c b/runtime/alloc.c index b3456b8bb33..ff3fe0edf8b 100644 --- a/runtime/alloc.c +++ b/runtime/alloc.c @@ -405,6 +405,8 @@ CAMLprim value caml_update_dummy(value dummy, value newval) tag = Tag_val (newval); + CAMLassert (tag != Infix_tag && tag != Closure_tag); + if (Wosize_val(dummy) == 0) { /* Size-0 blocks are statically-allocated atoms. We cannot mutate them, but there is no need: @@ -423,21 +425,6 @@ CAMLprim value caml_update_dummy(value dummy, value newval) for (i = 0; i < size; i++) { Store_double_flat_field (dummy, i, Double_flat_field (newval, i)); } - } else if (tag == Infix_tag) { - value clos = newval - Infix_offset_hd(Hd_val(newval)); - CAMLassert (Tag_val(clos) == Closure_tag); - CAMLassert (Tag_val(dummy) == Infix_tag); - CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval)); - dummy = dummy - Infix_offset_val(dummy); - size = Wosize_val(clos); - CAMLassert (size == Wosize_val(dummy)); - /* It is safe to use [caml_modify] to copy code pointers - from [clos] to [dummy], because the value being overwritten is - an integer, and the new "value" is a pointer outside the minor - heap. */ - for (i = 0; i < size; i++) { - caml_modify (&Field(dummy, i), Field(clos, i)); - } } else { CAMLassert (tag < No_scan_tag); CAMLassert (Tag_val(dummy) != Infix_tag); 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 ca518ecb840..6c4cce4cc7a 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/alloc.c b/runtime4/alloc.c index 1bb9ff2e196..c25b606859b 100644 --- a/runtime4/alloc.c +++ b/runtime4/alloc.c @@ -296,6 +296,8 @@ CAMLprim value caml_update_dummy(value dummy, value newval) tag = Tag_val (newval); + CAMLassert (tag != Infix_tag && tag != Closure_tag); + if (tag == Double_array_tag){ CAMLassert (Wosize_val(newval) == Wosize_val(dummy)); CAMLassert (Tag_val(dummy) != Infix_tag); @@ -304,21 +306,6 @@ CAMLprim value caml_update_dummy(value dummy, value newval) for (i = 0; i < size; i++) { Store_double_flat_field (dummy, i, Double_flat_field (newval, i)); } - } else if (tag == Infix_tag) { - value clos = newval - Infix_offset_hd(Hd_val(newval)); - CAMLassert (Tag_val(clos) == Closure_tag); - CAMLassert (Tag_val(dummy) == Infix_tag); - CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval)); - dummy = dummy - Infix_offset_val(dummy); - size = Wosize_val(clos); - CAMLassert (size == Wosize_val(dummy)); - /* It is safe to use [caml_modify] to copy code pointers - from [clos] to [dummy], because the value being overwritten is - an integer, and the new "value" is a pointer outside the minor - heap. */ - for (i = 0; i < size; i++) { - caml_modify (&Field(dummy, i), Field(clos, i)); - } } else { CAMLassert (tag < No_scan_tag); CAMLassert (Tag_val(dummy) != Infix_tag); 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 aa046e9e865..5261e191efe 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/capsule-api/data.ml b/testsuite/tests/capsule-api/data.ml index 9e661a4c362..9cfeac2f9c1 100644 --- a/testsuite/tests/capsule-api/data.ml +++ b/testsuite/tests/capsule-api/data.ml @@ -176,66 +176,9 @@ let () = assert (Capsule.Data.project ptr' = 111) ;; -(* [protect]. *) +(* [with_password]. *) exception Exn of string -let () = - match Capsule.protect (fun _password -> "ok") with - | s -> assert (s = "ok") - | exception _ -> assert false -;; - -let () = - match Capsule.protect (fun _password -> Exn "ok") with - | Exn s -> assert (s = "ok") - | _ -> assert false -;; - -let () = - 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 -> - match exn with - | Exn s -> s - | _ -> assert false) exn) in - assert (s = "fail") - | _ -> assert false -;; - -(* [with_password]. *) let () = match Capsule.with_password (fun _password -> "ok") with | s -> assert (s = "ok") 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/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/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 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/array_element_size_in_bytes.ml b/testsuite/tests/typing-layouts-arrays/array_element_size_in_bytes.ml new file mode 100644 index 00000000000..f4e9cad40b5 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/array_element_size_in_bytes.ml @@ -0,0 +1,233 @@ +(* TEST + flags = "-extension layouts_beta"; + flambda2; + stack-allocation; + arch_amd64; + { + bytecode; + } { + native; + } +*) + +(* CR layouts v4: The below definition is just to give this test slightly + different behavior on native code and bytecode, because some arrays of + unboxed things are represented as custom blocks on only native code, and + therefore the size calculations differ slightly. Delete this when we change + the representation to not use custom blocks. *) +let custom_block_padding = + match Sys.backend_type with + | Native -> 1 + | Bytecode -> 0 + | Other _ -> failwith "Don't know what to do" + +(* We only compile for 64 bits. *) +let bytes_per_word = 8 + +external[@layout_poly] size_in_bytes : ('a : any_non_null). 'a array -> int + = "%array_element_size_in_bytes" + +external[@layout_poly] makearray_dynamic : + ('a : any_non_null). int -> 'a -> 'a array = "%makearray_dynamic" + +let array_sizes_to_check = [0; 1; 2; 25] + +(* values *) +let check_value ~init ~element_size = + (* It is unfortunately necessary to duplicate this function many times because + we don't have layout polymorphism. *) + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let int_array_element_size = size_in_bytes ([||] : int array) +let _ = check_value ~init:42 ~element_size:int_array_element_size + +let string_array_element_size = size_in_bytes ([||] : string array) +let _ = check_value ~init:"abc" ~element_size:int_array_element_size + +let float_array_element_size = size_in_bytes ([||] : float array) +let _ = check_value ~init:42.0 ~element_size:int_array_element_size + +let float32_array_element_size = size_in_bytes ([||] : float32 array) +let _ = check_value ~init:42.0s ~element_size:int_array_element_size + +let int32_array_element_size = size_in_bytes ([||] : int32 array) +let _ = check_value ~init:42l ~element_size:int_array_element_size + +(* unboxed floats *) +let check_floatu ~init ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let floatu_array_element_size = size_in_bytes ([||] : float# array) + +let _ = check_floatu ~init:#42.0 ~element_size:floatu_array_element_size + +(* unboxed int64s *) +let check_int64u ~(init : int64#) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((custom_block_padding + (element_size * n / bytes_per_word)) + = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let int64u_array_element_size = size_in_bytes ([||] : int64# array) + +let _ = check_int64u ~init:#42L ~element_size:int64u_array_element_size + +(* unboxed float32s *) +let check_float32u ~(init : float32#) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* These arrays are packed in native code *) + let n = + match Sys.backend_type with + | Native -> if n mod 2 = 0 then n else n + 1 + | Bytecode -> n + | Other _ -> failwith "Don't know what to do" + in + assert ((custom_block_padding + (element_size * n / bytes_per_word)) + = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let float32u_array_element_size = size_in_bytes ([||] : float32# array) + +let _ = check_float32u ~init:#42.0s ~element_size:float32u_array_element_size + +(* unboxed int32s *) +let check_int32u ~(init : int32#) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* These arrays are packed in native code *) + let n = + match Sys.backend_type with + | Native -> if n mod 2 = 0 then n else n + 1 + | Bytecode -> n + | Other _ -> failwith "Don't know what to do" + in + assert ((custom_block_padding + (element_size * n / bytes_per_word)) + = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let int32u_array_element_size = size_in_bytes ([||] : int32# array) + +let _ = check_int32u ~init:#42l ~element_size:int32u_array_element_size + +(* simple scannable products *) +let check_scannable_product1 ~(init : #(int * string * int * float array)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let scannable_product1_array_element_size = + size_in_bytes ([||] : #(int * string * int * float array) array) + +let _ = check_scannable_product1 ~init:#(42, "hi", 0, [| 1.0; 2.0; 3.0 |]) + ~element_size:scannable_product1_array_element_size + +(* complex scannable products *) +type t_scan = #{ x : int; y : #(float * string); z: int option } + +let check_scannable_product2 ~(init : #(int * t_scan * string * t_scan)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let mk_el () = + #(42, + #{ x = 42; y = #(42.0, "hi"); z = Some 42 }, + "hi", + #{ x = 42; y = #(42.0, "hi"); z = Some 42 }) + +let scannable_product2_array_element_size = + size_in_bytes ([||] : #(int * t_scan * string * t_scan) array) + +let _ = check_scannable_product2 ~init:(mk_el ()) + ~element_size:scannable_product2_array_element_size + +(* simple ignorable products *) +let check_ignorable_product1 ~(init : #(int * float32# * int * int64#)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let ignorable_product1_array_element_size = + size_in_bytes ([||] : #(int * float32# * int * int64#) array) + +let _ = check_ignorable_product1 ~init:#(42, #42.0s, 0, #42L) + ~element_size:ignorable_product1_array_element_size + +(* complex ignorable products *) +type t_ignore = #{ x : int; y : #(float# * int32#); z: int32# } + +let check_ignorable_product2 ~(init : #(int * t_ignore * bool * t_ignore)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let mk_el () = + #(42, + #{ x = 42; y = #(#41.0, #40l); z = #43l }, + true, + #{ x = 42; y = #(#41.0, #40l); z = #43l }) + +let ignorable_product2_array_element_size = + size_in_bytes ([||] : #(int * t_ignore * bool * t_ignore) array) + +let _ = check_ignorable_product2 ~init:(mk_el ()) + ~element_size:ignorable_product2_array_element_size + +(* check lack of float32# packing in unboxed product arrays *) +let check_float32u_pair ~(init : #(float32# * float32#)) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* 2 because there are two components in the unboxed product *) + match Sys.backend_type with + | Native -> assert (n * 2 = (Obj.size (Obj.repr x))) + | Bytecode | Other _ -> assert (n = Obj.size (Obj.repr x)) + in + List.iter check_one array_sizes_to_check + +let float32u_pair_array_element_size = + size_in_bytes ([||] : #(int * t_ignore * bool * t_ignore) array) + +let _ = check_float32u_pair ~init:#(#1.0s, #42.1s) + ~element_size:float32u_pair_array_element_size + +(* check lack of int32# packing in unboxed product arrays *) +let check_int32u_pair ~(init : #(int32# * int32#)) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* 2 because there are two components in the unboxed product *) + match Sys.backend_type with + | Native -> assert (n * 2 = (Obj.size (Obj.repr x))) + | Bytecode | Other _ -> assert (n = Obj.size (Obj.repr x)) + in + List.iter check_one array_sizes_to_check + +let int32u_pair_array_element_size = + size_in_bytes ([||] : #(int * t_ignore * bool * t_ignore) array) + +let _ = check_int32u_pair ~init:#(#1l, #42l) + ~element_size:int32u_pair_array_element_size 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..0816841ebd4 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml @@ -0,0 +1,120 @@ +(* 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; + runtime5; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* This test exhibited intermittent failures with very low probability on + runtime4, and extensive investigation has not found the cause. It is + suspected it might be a problem in the runtime4 GC. So we have restricted + the test to runtime5 at least for now. *) + +(* 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..542311e673d --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml @@ -0,0 +1,117 @@ +(* 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; + runtime5; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* This test exhibited intermittent failures with very low probability on + runtime4, and extensive investigation has not found the cause. It is + suspected it might be a problem in the runtime4 GC. So we have restricted + the test to runtime5 at least for now. *) + +(* 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 88df08c5294..4520f1bd9ba 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; @@ -1519,13 +1516,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)) @@ -1569,13 +1560,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 = @@ -1584,17 +1569,10 @@ 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 = |}] -(* You can write the type of an array of unboxed records, but not create - one. Soon, you can do both. *) +(* You can write the type of an array of unboxed records and create one. *) type ('a : value & value) t1 = 'a array type ('a : bits64 & (value & float64)) t2 = 'a array @@ -1618,15 +1596,10 @@ 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}|] |}] +(* However, such records can't be passed to [Array.init]. *) type array_init_record = #{ i1 : int; i2 : int } let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) [%%expect{| @@ -1641,7 +1614,7 @@ Error: This expression has type "array_init_record" But the layout of array_init_record must be a sublayout of value. |}] -(* Arrays of unboxed records of kind value *are* allowed *) +(* Arrays of unboxed records of kind value *are* allowed in all cases *) type array_record = #{ i : int } let _ = [| #{ i = 1 } |] [%%expect{| 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/product_arrays.ml b/testsuite/tests/typing-layouts-products/product_arrays.ml index 2aaeeeec00e..d6aadab2171 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 @@ -2130,3 +2128,122 @@ Error: Unboxed product array elements must be external or contain all gc scannable types. The product type this function is applied at is not external but contains an element of sort float64. |}] + +(***************************************************) +(* Test 27: Typing of %array_element_size_in_bytes *) + +(* We check you get an error if using a non-value on either side, to guard + against people thinking you use it with the element type rather than the + array. *) + +external[@layout_poly] bytes_bad1 : ('a : any_non_null). 'a -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 36-66: +1 | external[@layout_poly] bytes_bad1 : ('a : any_non_null). 'a -> int + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad2 : ('a : any_non_null). 'a -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 43-45: +1 | external bytes_bad2 : ('a : any_non_null). 'a -> int + ^^ +Error: Types in an external must have a representable layout. + The layout of 'a is any + because of the annotation on the universal variable 'a. + But the layout of 'a must be representable + because it's the type of an argument in an external declaration. +|}] + +external bytes_bad3 : float# -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-35: +1 | external bytes_bad3 : float# -> int + ^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad4 : #(int * int) -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-41: +1 | external bytes_bad4 : #(int * int) -> int + ^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external[@layout_poly] bytes_bad5 : ('a : any_non_null). int -> 'a + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 36-66: +1 | external[@layout_poly] bytes_bad5 : ('a : any_non_null). int -> 'a + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad6 : ('a : any_non_null). int -> 'a + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 50-52: +1 | external bytes_bad6 : ('a : any_non_null). int -> 'a + ^^ +Error: Types in an external must have a representable layout. + The layout of 'a is any + because of the annotation on the universal variable 'a. + But the layout of 'a must be representable + because it's the type of the result of an external declaration. +|}] + +external bytes_bad7 : int -> float# + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-35: +1 | external bytes_bad7 : int -> float# + ^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad8 : int -> #(float# * float#) + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-47: +1 | external bytes_bad8 : int -> #(float# * float#) + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external[@layout_poly] bytes_good1 : ('a : any_non_null). 'a array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good1 : ('a : any_non_null). 'a array -> int + = "%array_element_size_in_bytes" [@@layout_poly] +|}] + +external bytes_good2 : int array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good2 : int array -> int = "%array_element_size_in_bytes" +|}] + +external bytes_good3 : float# array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good3 : float# array -> int = "%array_element_size_in_bytes" +|}] + +external bytes_good4 : #(float# * int) array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good4 : #(float# * int) array -> int + = "%array_element_size_in_bytes" +|}] 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-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-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-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/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/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/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/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/primitive.ml b/typing/primitive.ml index d2cc075844f..57abcff632a 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -674,6 +674,18 @@ 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); + ] + + | "%array_element_size_in_bytes" -> + 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/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..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 @@ -10815,6 +10818,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/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 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); diff --git a/typing/typeopt.ml b/typing/typeopt.ml index f76557ed36e..75389569b84 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 diff --git a/utils/doubly_linked_list.ml b/utils/doubly_linked_list.ml index b13e05b07bf..eeb64946fc2 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 for_all_i t ~f = let rec aux t f i curr = diff --git a/utils/doubly_linked_list.mli b/utils/doubly_linked_list.mli index e401d6cbe67..32d572f7a73 100644 --- a/utils/doubly_linked_list.mli +++ b/utils/doubly_linked_list.mli @@ -78,7 +78,7 @@ val exists : 'a t -> f:('a -> bool) -> bool val for_all : 'a t -> f:('a -> bool) -> bool -val for_all_i : 'a t -> f:(int -> 'a -> bool) -> bool +val for_alli : 'a t -> f:(int -> 'a -> bool) -> bool val to_list : 'a t -> 'a list