From 0f4d23e20a071d2b09923c1371448a115cb86567 Mon Sep 17 00:00:00 2001 From: alanechang Date: Fri, 15 Mar 2024 12:16:12 -0400 Subject: [PATCH] flambda-backend: Index arrays with unboxed ints (#2337) * wip * . * new primitives for unboxed int indexing * fix tests * bytegen * fix runtime * reduce diff * code cleanup * fix upstream * add comment in array_access_validity_condition --- bytecomp/bytegen.ml | 57 +++++-- lambda/lambda.ml | 26 +-- lambda/lambda.mli | 12 +- lambda/matching.ml | 2 +- lambda/printlambda.ml | 23 ++- lambda/transl_array_comprehension.ml | 6 +- lambda/translprim.ml | 97 ++++++++--- middle_end/convert_primitives.ml | 12 +- runtime/array.c | 47 ++++++ runtime4/array.c | 48 ++++++ .../array_spec.stack.flat.reference | 68 ++++---- .../module_coercion.compilers.flat.reference | 55 ++++--- .../unboxed_int_array_indexing.ml | 155 ++++++++++++++++++ .../unboxed_int_array_indexing.reference | 0 typing/primitive.ml | 81 ++++++++- 15 files changed, 574 insertions(+), 115 deletions(-) create mode 100644 testsuite/tests/typing-layouts/unboxed_int_array_indexing.ml create mode 100644 testsuite/tests/typing-layouts/unboxed_int_array_indexing.reference diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index eabd04cf7b5..b3d057f7b3d 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -425,6 +425,16 @@ let comp_bint_primitive bi suff args = | Pint64 -> "caml_int64_" in Kccall(pref ^ suff, List.length args) +let array_primitive (index_kind : Lambda.array_index_kind) prefix = + let suffix = + match index_kind with + | Ptagged_int_index -> "" + | Punboxed_int_index Pint64 -> "_indexed_by_int64" + | Punboxed_int_index Pint32 -> "_indexed_by_int32" + | Punboxed_int_index Pnativeint -> "_indexed_by_nativeint" + in + prefix ^ suffix + let comp_primitive stack_info p sz args = check_stack stack_info sz; match p with @@ -504,30 +514,45 @@ let comp_primitive stack_info p sz args = (* In bytecode, nothing is ever actually stack-allocated, so we ignore the array modes (allocation for [Parrayref{s,u}], modification for [Parrayset{s,u}]). *) - | Parrayrefs (Pgenarray_ref _) -> Kccall("caml_array_get", 2) - | Parrayrefs (Pfloatarray_ref _) -> Kccall("caml_floatarray_get", 2) - | Parrayrefs (Paddrarray_ref | Pintarray_ref) -> + | Parrayrefs (Pgenarray_ref _, index_kind) + | Parrayrefs ((Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _), + (Punboxed_int_index _ as index_kind)) -> + Kccall(array_primitive index_kind "caml_array_get", 2) + | Parrayrefs (Pfloatarray_ref _, Ptagged_int_index) -> + Kccall("caml_floatarray_get", 2) + | Parrayrefs ((Paddrarray_ref | Pintarray_ref), Ptagged_int_index) -> Kccall("caml_array_get_addr", 2) - | Parrayrefs (Punboxedfloatarray_ref _ | Punboxedintarray_ref _) -> + | Parrayrefs ((Punboxedfloatarray_ref _ | Punboxedintarray_ref _), _) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p - | Parraysets (Pgenarray_set _) -> Kccall("caml_array_set", 3) - | Parraysets Pfloatarray_set -> Kccall("caml_floatarray_set", 3) - | Parraysets (Paddrarray_set _ | Pintarray_set) -> + | Parraysets (Pgenarray_set _, index_kind) + | Parraysets ((Paddrarray_set _ | Pintarray_set | Pfloatarray_set), + (Punboxed_int_index _ as index_kind)) -> + Kccall(array_primitive index_kind "caml_array_set", 3) + | Parraysets (Pfloatarray_set, Ptagged_int_index) -> Kccall("caml_floatarray_set", 3) + | Parraysets ((Paddrarray_set _ | Pintarray_set), Ptagged_int_index) -> Kccall("caml_array_set_addr", 3) - | Parraysets (Punboxedfloatarray_set _ | Punboxedintarray_set _) -> + | Parraysets ((Punboxedfloatarray_set _ | Punboxedintarray_set _), _index_kind) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p - | Parrayrefu (Pgenarray_ref _) -> Kccall("caml_array_unsafe_get", 2) - | Parrayrefu (Pfloatarray_ref _) -> Kccall("caml_floatarray_unsafe_get", 2) - | Parrayrefu (Paddrarray_ref | Pintarray_ref) -> Kgetvectitem - | Parrayrefu (Punboxedfloatarray_ref _ | Punboxedintarray_ref _) -> + | Parrayrefu (Pgenarray_ref _, index_kind) + | Parrayrefu ((Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _), + (Punboxed_int_index _ as index_kind)) -> + Kccall(array_primitive index_kind "caml_array_unsafe_get", 2) + | Parrayrefu (Pfloatarray_ref _, Ptagged_int_index) -> + Kccall("caml_floatarray_unsafe_get", 2) + | Parrayrefu ((Paddrarray_ref | Pintarray_ref), Ptagged_int_index) -> Kgetvectitem + | Parrayrefu ((Punboxedfloatarray_ref _ | Punboxedintarray_ref _), _index_kind) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p - | Parraysetu (Pgenarray_set _) -> Kccall("caml_array_unsafe_set", 3) - | Parraysetu Pfloatarray_set -> Kccall("caml_floatarray_unsafe_set", 3) - | Parraysetu (Paddrarray_set _ | Pintarray_set) -> Ksetvectitem - | Parraysetu (Punboxedfloatarray_set _ | Punboxedintarray_set _) -> + | Parraysetu (Pgenarray_set _, index_kind) + | Parraysetu ((Paddrarray_set _ | Pintarray_set | Pfloatarray_set), + (Punboxed_int_index _ as index_kind)) -> + Kccall(array_primitive index_kind "caml_array_unsafe_set", 3) + | Parraysetu (Pfloatarray_set, Ptagged_int_index) -> + Kccall("caml_floatarray_unsafe_set", 3) + | Parraysetu ((Paddrarray_set _ | Pintarray_set), Ptagged_int_index) -> Ksetvectitem + | Parraysetu ((Punboxedfloatarray_set _ | Punboxedintarray_set _), _index_kind) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p | Pctconst c -> diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 34780ed6025..0a28a97c13e 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -197,10 +197,10 @@ type primitive = | Pmakearray of array_kind * mutable_flag * alloc_mode | Pduparray of array_kind * mutable_flag | Parraylength of array_kind - | Parrayrefu of array_ref_kind - | Parraysetu of array_set_kind - | Parrayrefs of array_ref_kind - | Parraysets of array_set_kind + | Parrayrefu of array_ref_kind * array_index_kind + | Parraysetu of array_set_kind * array_index_kind + | Parrayrefs of array_ref_kind * array_index_kind + | Parraysets of array_set_kind * array_index_kind (* Test if the argument is a block or an immediate integer *) | Pisint of { variant_only : bool } (* Test if the (integer) argument is outside an interval *) @@ -358,6 +358,10 @@ and array_set_kind = | Punboxedfloatarray_set of unboxed_float | Punboxedintarray_set of unboxed_integer +and array_index_kind = + | Ptagged_int_index + | Punboxed_int_index of unboxed_integer + and boxed_float = Primitive.boxed_float = | Pfloat64 | Pfloat32 @@ -1586,12 +1590,12 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pduparray _ -> Some alloc_heap | Parraylength _ -> None | Parraysetu _ | Parraysets _ - | Parrayrefu (Paddrarray_ref | Pintarray_ref - | Punboxedfloatarray_ref _ | Punboxedintarray_ref _) - | Parrayrefs (Paddrarray_ref | Pintarray_ref - | Punboxedfloatarray_ref _ | Punboxedintarray_ref _) -> None - | Parrayrefu (Pgenarray_ref m | Pfloatarray_ref m) - | Parrayrefs (Pgenarray_ref m | Pfloatarray_ref m) -> Some m + | Parrayrefu ((Paddrarray_ref | Pintarray_ref + | Punboxedfloatarray_ref _ | Punboxedintarray_ref _), _) + | Parrayrefs ((Paddrarray_ref | Pintarray_ref + | Punboxedfloatarray_ref _ | Punboxedintarray_ref _), _) -> None + | Parrayrefu ((Pgenarray_ref m | Pfloatarray_ref m), _) + | Parrayrefs ((Pgenarray_ref m | Pfloatarray_ref m), _) -> Some m | Pisint _ | Pisout -> None | Pintofbint _ -> None | Pbintofint (_,m) @@ -1743,7 +1747,7 @@ let primitive_result_layout (p : primitive) = | Pstring_load_16 _ | Pbytes_load_16 _ | Pbigstring_load_16 _ | Pprobe_is_enabled _ | Pbswap16 -> layout_int - | Parrayrefu array_ref_kind | Parrayrefs array_ref_kind -> + | Parrayrefu (array_ref_kind, _) | Parrayrefs (array_ref_kind, _) -> array_ref_kind_result_layout array_ref_kind | Pbintofint (bi, _) | Pcvtbint (_,bi,_) | Pnegbint (bi, _) | Paddbint (bi, _) | Psubbint (bi, _) diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 5f101f3e69f..c437ba46429 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -159,10 +159,10 @@ type primitive = The arguments of [Pduparray] give the kind and mutability of the array being *produced* by the duplication. *) | Parraylength of array_kind - | Parrayrefu of array_ref_kind - | Parraysetu of array_set_kind - | Parrayrefs of array_ref_kind - | Parraysets of array_set_kind + | Parrayrefu of array_ref_kind * array_index_kind + | Parraysetu of array_set_kind * array_index_kind + | Parrayrefs of array_ref_kind * array_index_kind + | Parraysets of array_set_kind * array_index_kind (* Test if the argument is a block or an immediate integer *) | Pisint of { variant_only : bool } (* Test if the (integer) argument is outside an interval *) @@ -308,6 +308,10 @@ and array_set_kind = | Punboxedfloatarray_set of unboxed_float | Punboxedintarray_set of unboxed_integer +and array_index_kind = + | Ptagged_int_index + | Punboxed_int_index of unboxed_integer + and value_kind = | Pgenval | Pintval diff --git a/lambda/matching.ml b/lambda/matching.ml index 5dbca357150..27c4565d595 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -2219,7 +2219,7 @@ let get_expr_args_array ~scopes kind head (arg, _mut, _sort, _layout) rem = let ref_kind = Lambda.(array_ref_kind alloc_heap kind) in let result_layout = array_ref_kind_result_layout ref_kind in ( Lprim - (Parrayrefu ref_kind, + (Parrayrefu (ref_kind, Ptagged_int_index), [ arg; Lconst (Const_base (Const_int pos)) ], loc), (match am with diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index a4fe41b2b2f..dd8a6e81226 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -83,6 +83,13 @@ let array_ref_kind ppf k = | Punboxedintarray_ref Pint64 -> fprintf ppf "unboxed_int64" | Punboxedintarray_ref Pnativeint -> fprintf ppf "unboxed_nativeint" +let array_index_kind ppf k = + match k with + | Ptagged_int_index -> fprintf ppf "int" + | Punboxed_int_index Pint32 -> fprintf ppf "unboxed_int32" + | Punboxed_int_index Pint64 -> fprintf ppf "unboxed_int64" + | Punboxed_int_index Pnativeint -> fprintf ppf "unboxed_nativeint" + let array_set_kind ppf k = let pp_mode ppf = function | Modify_heap -> () @@ -482,10 +489,18 @@ let primitive ppf = function | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) | Pduparray (k, Immutable_unique) -> fprintf ppf "duparray_unique[%s]" (array_kind k) - | Parrayrefu rk -> fprintf ppf "array.unsafe_get[%a]" array_ref_kind rk - | Parraysetu sk -> fprintf ppf "array.unsafe_set[%a]" array_set_kind sk - | Parrayrefs rk -> fprintf ppf "array.get[%a]" array_ref_kind rk - | Parraysets sk -> fprintf ppf "array.set[%a]" array_set_kind sk + | Parrayrefu (rk, idx) -> fprintf ppf "array.unsafe_get[%a indexed by %a]" + array_ref_kind rk + array_index_kind idx + | Parraysetu (sk, idx) -> fprintf ppf "array.unsafe_set[%a indexed by %a]" + array_set_kind sk + array_index_kind idx + | Parrayrefs (rk, idx) -> fprintf ppf "array.get[%a indexed by %a]" + array_ref_kind rk + array_index_kind idx + | Parraysets (sk, idx) -> fprintf ppf "array.set[%a indexed by %a]" + array_set_kind sk + array_index_kind idx | Pctconst c -> let const_name = match c with | Big_endian -> "big_endian" diff --git a/lambda/transl_array_comprehension.ml b/lambda/transl_array_comprehension.ml index 8181b71d14e..235aec1df48 100644 --- a/lambda/transl_array_comprehension.ml +++ b/lambda/transl_array_comprehension.ml @@ -495,7 +495,8 @@ let iterator ~transl_exp ~scopes ~loc ~return_layout:(Pvalue Pintval) pattern.pat_loc (Lprim(Parrayrefu - Lambda.(array_ref_kind alloc_heap iter_arr_kind), + (Lambda.(array_ref_kind alloc_heap iter_arr_kind), + Ptagged_int_index), [iter_arr.var; Lvar iter_ix], loc)) pattern @@ -776,7 +777,8 @@ let body let open Let_binding in let set_element_raw elt = (* array.(index) <- elt *) - Lprim(Parraysetu Lambda.(array_set_kind modify_heap array_kind), + Lprim(Parraysetu (Lambda.(array_set_kind modify_heap array_kind), + Ptagged_int_index), [array.var; index.var; elt], loc) in diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 3f063113e2a..007c5c2df42 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -293,23 +293,82 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%bytes_unsafe_get" -> Primitive (Pbytesrefu, 2) | "%bytes_unsafe_set" -> Primitive (Pbytessetu, 3) | "%array_length" -> Primitive ((Parraylength gen_array_kind), 1) - | "%array_safe_get" -> Primitive ((Parrayrefs (gen_array_ref_kind mode)), 2) + | "%array_safe_get" -> + Primitive + ((Parrayrefs (gen_array_ref_kind mode, Ptagged_int_index)), 2) | "%array_safe_set" -> - Primitive (Parraysets (gen_array_set_kind (get_first_arg_mode ())), 3) - | "%array_unsafe_get" -> Primitive (Parrayrefu (gen_array_ref_kind mode), 2) + Primitive + (Parraysets (gen_array_set_kind (get_first_arg_mode ()), Ptagged_int_index), + 3) + | "%array_unsafe_get" -> + Primitive + (Parrayrefu (gen_array_ref_kind mode, Ptagged_int_index), 2) | "%array_unsafe_set" -> - Primitive ((Parraysetu (gen_array_set_kind (get_first_arg_mode ()))), 3) + Primitive + ((Parraysetu (gen_array_set_kind (get_first_arg_mode ()), Ptagged_int_index)), + 3) + | "%array_safe_get_indexed_by_int64#" -> + Primitive + ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Pint64)), 2) + | "%array_safe_set_indexed_by_int64#" -> + Primitive + (Parraysets + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint64), + 3) + | "%array_unsafe_get_indexed_by_int64#" -> + Primitive + (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Pint64), 2) + | "%array_unsafe_set_indexed_by_int64#" -> + Primitive + ((Parraysetu + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint64)), + 3) + | "%array_safe_get_indexed_by_int32#" -> + Primitive + ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Pint32)), 2) + | "%array_safe_set_indexed_by_int32#" -> + Primitive + (Parraysets + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint32), + 3) + | "%array_unsafe_get_indexed_by_int32#" -> + Primitive + (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Pint32), 2) + | "%array_unsafe_set_indexed_by_int32#" -> + Primitive + ((Parraysetu + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint32)), + 3) + | "%array_safe_get_indexed_by_nativeint#" -> + Primitive + ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Pnativeint)), 2) + | "%array_safe_set_indexed_by_nativeint#" -> + Primitive + (Parraysets + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pnativeint), + 3) + | "%array_unsafe_get_indexed_by_nativeint#" -> + Primitive + (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Pnativeint), 2) + | "%array_unsafe_set_indexed_by_nativeint#" -> + Primitive + ((Parraysetu + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pnativeint)), + 3) | "%obj_size" -> Primitive ((Parraylength Pgenarray), 1) - | "%obj_field" -> Primitive ((Parrayrefu (Pgenarray_ref mode)), 2) + | "%obj_field" -> Primitive ((Parrayrefu (Pgenarray_ref mode, Ptagged_int_index)), 2) | "%obj_set_field" -> - Primitive ((Parraysetu (Pgenarray_set (get_first_arg_mode ()))), 3) + Primitive + ((Parraysetu (Pgenarray_set (get_first_arg_mode ()), Ptagged_int_index)), 3) | "%floatarray_length" -> Primitive ((Parraylength Pfloatarray), 1) | "%floatarray_safe_get" -> - Primitive ((Parrayrefs (Pfloatarray_ref mode)), 2) - | "%floatarray_safe_set" -> Primitive (Parraysets Pfloatarray_set, 3) + Primitive ((Parrayrefs (Pfloatarray_ref mode, Ptagged_int_index)), 2) + | "%floatarray_safe_set" -> + Primitive (Parraysets (Pfloatarray_set, Ptagged_int_index), 3) | "%floatarray_unsafe_get" -> - Primitive ((Parrayrefu (Pfloatarray_ref mode)), 2) - | "%floatarray_unsafe_set" -> Primitive ((Parraysetu Pfloatarray_set), 3) + Primitive ((Parrayrefu (Pfloatarray_ref mode, Ptagged_int_index)), 2) + | "%floatarray_unsafe_set" -> + Primitive ((Parraysetu (Pfloatarray_set, Ptagged_int_index)), 3) | "%obj_is_int" -> Primitive (Pisint { variant_only = false }, 1) | "%lazy_force" -> Lazy_force pos | "%nativeint_of_int" -> Primitive ((Pbintofint (Pnativeint, mode)), 1) @@ -807,26 +866,26 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = if t = array_type then None else Some (Primitive (Parraylength array_type, arity)) end - | Primitive (Parrayrefu rt, arity), p1 :: _ -> begin + | Primitive (Parrayrefu (rt, index_kind), arity), p1 :: _ -> begin let array_ref_type = glb_array_ref_type (to_location loc) rt (array_type_kind env p1) in if rt = array_ref_type then None - else Some (Primitive (Parrayrefu array_ref_type, arity)) + else Some (Primitive (Parrayrefu (array_ref_type, index_kind), arity)) end - | Primitive (Parraysetu st, arity), p1 :: _ -> begin + | Primitive (Parraysetu (st, index_kind), arity), p1 :: _ -> begin let array_set_type = glb_array_set_type (to_location loc) st (array_type_kind env p1) in if st = array_set_type then None - else Some (Primitive (Parraysetu array_set_type, arity)) + else Some (Primitive (Parraysetu (array_set_type, index_kind), arity)) end - | Primitive (Parrayrefs rt, arity), p1 :: _ -> begin + | Primitive (Parrayrefs (rt, index_kind), arity), p1 :: _ -> begin let array_ref_type = glb_array_ref_type (to_location loc) rt (array_type_kind env p1) in if rt = array_ref_type then None - else Some (Primitive (Parrayrefs array_ref_type, arity)) + else Some (Primitive (Parrayrefs (array_ref_type, index_kind), arity)) end - | Primitive (Parraysets st, arity), p1 :: _ -> begin + | Primitive (Parraysets (st, index_kind), arity), p1 :: _ -> begin let array_set_type = glb_array_set_type (to_location loc) st (array_type_kind env p1) in if st = array_set_type then None - else Some (Primitive (Parraysets array_set_type, arity)) + else Some (Primitive (Parraysets (array_set_type, index_kind), arity)) end | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), arity), p1 :: _ -> begin @@ -1293,7 +1352,7 @@ let lambda_primitive_needs_event_after = function | Pmulfloat (_, _) | Pdivfloat (_, _) | Pstringrefs | Pbytesrefs | Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _ - | Parrayrefu (Pgenarray_ref _ | Pfloatarray_ref _) + | Parrayrefu ((Pgenarray_ref _ | Pfloatarray_ref _), _) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 1dda02bb8ff..94906e2f551 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -99,10 +99,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pmakearray (kind, mutability, mode) -> Pmakearray (kind, mutability, mode) | Pduparray (kind, mutability) -> Pduparray (kind, mutability) | Parraylength kind -> Parraylength kind - | Parrayrefu rkind -> Parrayrefu rkind - | Parraysetu skind -> Parraysetu skind - | Parrayrefs rkind -> Parrayrefs rkind - | Parraysets skind -> Parraysets skind + | Parrayrefu (rkind, Ptagged_int_index) -> Parrayrefu rkind + | Parraysetu (skind, Ptagged_int_index) -> Parraysetu skind + | Parrayrefs (rkind, Ptagged_int_index) -> Parrayrefs rkind + | Parraysets (skind, Ptagged_int_index) -> Parraysets skind | Pisint _ -> Pisint | Pisout -> Pisout | Pcvtbint (src, dest, m) -> Pcvtbint (src, dest, m) @@ -219,6 +219,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _ | Punboxed_nativeint_array_set_128 _ + | Parrayrefu (_, Punboxed_int_index _) + | Parraysetu (_, Punboxed_int_index _) + | Parrayrefs (_, Punboxed_int_index _) + | Parraysets (_, Punboxed_int_index _) -> Misc.fatal_errorf "lambda primitive %a can't be converted to \ clambda primitive" diff --git a/runtime/array.c b/runtime/array.c index 5e3a0065ed4..da4a425fb0e 100644 --- a/runtime/array.c +++ b/runtime/array.c @@ -880,3 +880,50 @@ CAMLprim value caml_array_of_iarray(value a) { return a; } + +/* We need these pre-declared for [gen_primitives.sh] to work. */ +CAMLprim value caml_array_get_indexed_by_int64(value, value); +CAMLprim value caml_array_unsafe_get_indexed_by_int64(value, value); +CAMLprim value caml_array_set_indexed_by_int64(value, value, value); +CAMLprim value caml_array_unsafe_set_indexed_by_int64(value, value, value); + +CAMLprim value caml_array_get_indexed_by_int32(value, value); +CAMLprim value caml_array_unsafe_get_indexed_by_int32(value, value); +CAMLprim value caml_array_set_indexed_by_int32(value, value, value); +CAMLprim value caml_array_unsafe_set_indexed_by_int32(value, value, value); + +CAMLprim value caml_array_get_indexed_by_nativeint(value, value); +CAMLprim value caml_array_unsafe_get_indexed_by_nativeint(value, value); +CAMLprim value caml_array_set_indexed_by_nativeint(value, value, value); +CAMLprim value caml_array_unsafe_set_indexed_by_nativeint(value, value, value); + +#define CAMLprim_indexed_by(name, index_type, val_func) \ + CAMLprim value caml_array_get_indexed_by_##name(value array, value index) \ + { \ + index_type idx = val_func(index); \ + if (idx != Long_val(Val_long(idx))) caml_array_bound_error(); \ + return caml_array_get(array, Val_long(idx)); \ + } \ + CAMLprim value caml_array_unsafe_get_indexed_by_##name(value array, \ + value index) \ + { \ + return caml_array_unsafe_get(array, Val_long(val_func(index))); \ + } \ + CAMLprim value caml_array_set_indexed_by_##name(value array, \ + value index, \ + value newval) \ + { \ + index_type idx = val_func(index); \ + if (idx != Long_val(Val_long(idx))) caml_array_bound_error(); \ + return caml_array_set(array, Val_long(idx), newval); \ + } \ + CAMLprim value caml_array_unsafe_set_indexed_by_##name(value array, \ + value index, \ + value newval) \ + { \ + return caml_array_unsafe_set(array, Val_long(val_func(index)), newval); \ + } + +CAMLprim_indexed_by(int64, int64_t, Int64_val) +CAMLprim_indexed_by(int32, int32_t, Int32_val) +CAMLprim_indexed_by(nativeint, intnat, Nativeint_val) diff --git a/runtime4/array.c b/runtime4/array.c index 4c123052618..df0672b2e87 100644 --- a/runtime4/array.c +++ b/runtime4/array.c @@ -843,3 +843,51 @@ CAMLprim value caml_array_of_iarray(value a) { return a; } + + +/* We need these pre-declared for [gen_primitives.sh] to work. */ +CAMLprim value caml_array_get_indexed_by_int64(value, value); +CAMLprim value caml_array_unsafe_get_indexed_by_int64(value, value); +CAMLprim value caml_array_set_indexed_by_int64(value, value, value); +CAMLprim value caml_array_unsafe_set_indexed_by_int64(value, value, value); + +CAMLprim value caml_array_get_indexed_by_int32(value, value); +CAMLprim value caml_array_unsafe_get_indexed_by_int32(value, value); +CAMLprim value caml_array_set_indexed_by_int32(value, value, value); +CAMLprim value caml_array_unsafe_set_indexed_by_int32(value, value, value); + +CAMLprim value caml_array_get_indexed_by_nativeint(value, value); +CAMLprim value caml_array_unsafe_get_indexed_by_nativeint(value, value); +CAMLprim value caml_array_set_indexed_by_nativeint(value, value, value); +CAMLprim value caml_array_unsafe_set_indexed_by_nativeint(value, value, value); + +#define CAMLprim_indexed_by(name, index_type, val_func) \ + CAMLprim value caml_array_get_indexed_by_##name(value array, value index) \ + { \ + index_type idx = val_func(index); \ + if (idx != Long_val(Val_long(idx))) caml_array_bound_error(); \ + return caml_array_get(array, Val_long(idx)); \ + } \ + CAMLprim value caml_array_unsafe_get_indexed_by_##name(value array, \ + value index) \ + { \ + return caml_array_unsafe_get(array, Val_long(val_func(index))); \ + } \ + CAMLprim value caml_array_set_indexed_by_##name(value array, \ + value index, \ + value newval) \ + { \ + index_type idx = val_func(index); \ + if (idx != Long_val(Val_long(idx))) caml_array_bound_error(); \ + return caml_array_set(array, Val_long(idx), newval); \ + } \ + CAMLprim value caml_array_unsafe_set_indexed_by_##name(value array, \ + value index, \ + value newval) \ + { \ + return caml_array_unsafe_set(array, Val_long(val_func(index)), newval); \ + } + +CAMLprim_indexed_by(int64, int64_t, Int64_val) +CAMLprim_indexed_by(int32, int32_t, Int32_val) +CAMLprim_indexed_by(nativeint, intnat, Nativeint_val) diff --git a/testsuite/tests/translprim/array_spec.stack.flat.reference b/testsuite/tests/translprim/array_spec.stack.flat.reference index 9e2b535ac06..6eac8d782d9 100644 --- a/testsuite/tests/translprim/array_spec.stack.flat.reference +++ b/testsuite/tests/translprim/array_spec.stack.flat.reference @@ -6,92 +6,102 @@ (seq (array.length[int] int_a) (array.length[float] float_a) (array.length[addr] addr_a) (function {nlocal = 0} a[genarray] : int (array.length[gen] a)) - (array.get[int] int_a 0) (array.get[float] float_a 0) - (array.get[addr] addr_a 0) - (function {nlocal = 0} a[genarray] (array.get[gen] a 0)) - (array.unsafe_get[int] int_a 0) (array.unsafe_get[float] float_a 0) - (array.unsafe_get[addr] addr_a 0) - (function {nlocal = 0} a[genarray] (array.unsafe_get[gen] a 0)) - (array.set[int] int_a 0 1) (array.set[float] float_a 0 1.) - (array.set[addr] addr_a 0 "a") - (function {nlocal = 2} a[genarray] x : int (array.set[gen] a 0 x)) - (array.unsafe_set[int] int_a 0 1) - (array.unsafe_set[float] float_a 0 1.) - (array.unsafe_set[addr] addr_a 0 "a") + (array.get[int indexed by int] int_a 0) + (array.get[float indexed by int] float_a 0) + (array.get[addr indexed by int] addr_a 0) + (function {nlocal = 0} a[genarray] (array.get[gen indexed by int] a 0)) + (array.unsafe_get[int indexed by int] int_a 0) + (array.unsafe_get[float indexed by int] float_a 0) + (array.unsafe_get[addr indexed by int] addr_a 0) + (function {nlocal = 0} a[genarray] + (array.unsafe_get[gen indexed by int] a 0)) + (array.set[int indexed by int] int_a 0 1) + (array.set[float indexed by int] float_a 0 1.) + (array.set[addr indexed by int] addr_a 0 "a") (function {nlocal = 2} a[genarray] x : int - (array.unsafe_set[gen] a 0 x)) + (array.set[gen indexed by int] a 0 x)) + (array.unsafe_set[int indexed by int] int_a 0 1) + (array.unsafe_set[float indexed by int] float_a 0 1.) + (array.unsafe_set[addr indexed by int] addr_a 0 "a") + (function {nlocal = 2} a[genarray] x : int + (array.unsafe_set[gen indexed by int] a 0 x)) (let (eta_gen_len = (function {nlocal = 0} prim[genarray] stub ignore assert all zero_alloc : int (array.length[gen] prim)) eta_gen_safe_get = (function {nlocal = 0} prim[genarray] prim[int] stub - ignore assert all zero_alloc (array.get[gen] prim prim)) + ignore assert all zero_alloc + (array.get[gen indexed by int] prim prim)) eta_gen_unsafe_get = (function {nlocal = 0} prim[genarray] prim[int] stub - ignore assert all zero_alloc (array.unsafe_get[gen] prim prim)) + ignore assert all zero_alloc + (array.unsafe_get[gen indexed by int] prim prim)) eta_gen_safe_set = (function {nlocal = 0} prim[genarray] prim[int] prim stub ignore assert all zero_alloc : int - (array.set[gen] prim prim prim)) + (array.set[gen indexed by int] prim prim prim)) eta_gen_unsafe_set = (function {nlocal = 0} prim[genarray] prim[int] prim stub ignore assert all zero_alloc : int - (array.unsafe_set[gen] prim prim prim)) + (array.unsafe_set[gen indexed by int] prim prim prim)) eta_int_len = (function {nlocal = 0} prim[intarray] stub ignore assert all zero_alloc : int (array.length[int] prim)) eta_int_safe_get = (function {nlocal = 0} prim[intarray] prim[int] stub - ignore assert all zero_alloc : int (array.get[int] prim prim)) + ignore assert all zero_alloc : int + (array.get[int indexed by int] prim prim)) eta_int_unsafe_get = (function {nlocal = 0} prim[intarray] prim[int] stub ignore assert all zero_alloc : int - (array.unsafe_get[int] prim prim)) + (array.unsafe_get[int indexed by int] prim prim)) eta_int_safe_set = (function {nlocal = 0} prim[intarray] prim[int] prim[int] stub ignore assert all zero_alloc : int - (array.set[int] prim prim prim)) + (array.set[int indexed by int] prim prim prim)) eta_int_unsafe_set = (function {nlocal = 0} prim[intarray] prim[int] prim[int] stub ignore assert all zero_alloc : int - (array.unsafe_set[int] prim prim prim)) + (array.unsafe_set[int indexed by int] prim prim prim)) eta_float_len = (function {nlocal = 0} prim[floatarray] stub ignore assert all zero_alloc : int (array.length[float] prim)) eta_float_safe_get = (function {nlocal = 0} prim[floatarray] prim[int] stub ignore assert all zero_alloc : float - (array.get[float] prim prim)) + (array.get[float indexed by int] prim prim)) eta_float_unsafe_get = (function {nlocal = 0} prim[floatarray] prim[int] stub ignore assert all zero_alloc : float - (array.unsafe_get[float] prim prim)) + (array.unsafe_get[float indexed by int] prim prim)) eta_float_safe_set = (function {nlocal = 0} prim[floatarray] prim[int] prim[float] stub ignore assert all zero_alloc : int - (array.set[float] prim prim prim)) + (array.set[float indexed by int] prim prim prim)) eta_float_unsafe_set = (function {nlocal = 0} prim[floatarray] prim[int] prim[float] stub ignore assert all zero_alloc : int - (array.unsafe_set[float] prim prim prim)) + (array.unsafe_set[float indexed by int] prim prim prim)) eta_addr_len = (function {nlocal = 0} prim[addrarray] stub ignore assert all zero_alloc : int (array.length[addr] prim)) eta_addr_safe_get = (function {nlocal = 0} prim[addrarray] prim[int] stub - ignore assert all zero_alloc (array.get[addr] prim prim)) + ignore assert all zero_alloc + (array.get[addr indexed by int] prim prim)) eta_addr_unsafe_get = (function {nlocal = 0} prim[addrarray] prim[int] stub - ignore assert all zero_alloc (array.unsafe_get[addr] prim prim)) + ignore assert all zero_alloc + (array.unsafe_get[addr indexed by int] prim prim)) eta_addr_safe_set = (function {nlocal = 0} prim[addrarray] prim[int] prim stub ignore assert all zero_alloc : int - (array.set[addr] prim prim prim)) + (array.set[addr indexed by int] prim prim prim)) eta_addr_unsafe_set = (function {nlocal = 0} prim[addrarray] prim[int] prim stub ignore assert all zero_alloc : int - (array.unsafe_set[addr] prim prim prim))) + (array.unsafe_set[addr indexed by int] prim prim prim))) (makeblock 0 int_a float_a addr_a eta_gen_len eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set eta_gen_unsafe_set eta_int_len eta_int_safe_get eta_int_unsafe_get eta_int_safe_set diff --git a/testsuite/tests/translprim/module_coercion.compilers.flat.reference b/testsuite/tests/translprim/module_coercion.compilers.flat.reference index 4ff742cba21..e0d5f5b4ed5 100644 --- a/testsuite/tests/translprim/module_coercion.compilers.flat.reference +++ b/testsuite/tests/translprim/module_coercion.compilers.flat.reference @@ -5,15 +5,17 @@ (function {nlocal = 0} prim[intarray] stub ignore assert all zero_alloc : int (array.length[int] prim)) (function {nlocal = 0} prim[intarray] prim[int] stub - ignore assert all zero_alloc : int (array.get[int] prim prim)) + ignore assert all zero_alloc : int + (array.get[int indexed by int] prim prim)) (function {nlocal = 0} prim[intarray] prim[int] stub ignore assert all zero_alloc : int - (array.unsafe_get[int] prim prim)) + (array.unsafe_get[int indexed by int] prim prim)) (function {nlocal = 0} prim[intarray] prim[int] prim[int] stub - ignore assert all zero_alloc : int (array.set[int] prim prim prim)) + ignore assert all zero_alloc : int + (array.set[int indexed by int] prim prim prim)) (function {nlocal = 0} prim[intarray] prim[int] prim[int] stub ignore assert all zero_alloc : int - (array.unsafe_set[int] prim prim prim)) + (array.unsafe_set[int indexed by int] prim prim prim)) (function {nlocal = 0} prim[int] prim[int] stub ignore assert all zero_alloc : int (compare_ints prim prim)) (function {nlocal = 0} prim[int] prim[int] stub @@ -32,16 +34,17 @@ (function {nlocal = 0} prim[floatarray] stub ignore assert all zero_alloc : int (array.length[float] prim)) (function {nlocal = 0} prim[floatarray] prim[int] stub - ignore assert all zero_alloc : float (array.get[float] prim prim)) + ignore assert all zero_alloc : float + (array.get[float indexed by int] prim prim)) (function {nlocal = 0} prim[floatarray] prim[int] stub ignore assert all zero_alloc : float - (array.unsafe_get[float] prim prim)) + (array.unsafe_get[float indexed by int] prim prim)) (function {nlocal = 0} prim[floatarray] prim[int] prim[float] stub ignore assert all zero_alloc : int - (array.set[float] prim prim prim)) + (array.set[float indexed by int] prim prim prim)) (function {nlocal = 0} prim[floatarray] prim[int] prim[float] stub ignore assert all zero_alloc : int - (array.unsafe_set[float] prim prim prim)) + (array.unsafe_set[float indexed by int] prim prim prim)) (function {nlocal = 0} prim[float] prim[float] stub ignore assert all zero_alloc : int (compare_floats float prim prim)) @@ -61,15 +64,17 @@ (function {nlocal = 0} prim[addrarray] stub ignore assert all zero_alloc : int (array.length[addr] prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub - ignore assert all zero_alloc (array.get[addr] prim prim)) + ignore assert all zero_alloc + (array.get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub - ignore assert all zero_alloc (array.unsafe_get[addr] prim prim)) + ignore assert all zero_alloc + (array.unsafe_get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim stub ignore assert all zero_alloc : int - (array.set[addr] prim prim prim)) + (array.set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim stub ignore assert all zero_alloc : int - (array.unsafe_set[addr] prim prim prim)) + (array.unsafe_set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_compare prim prim)) (function {nlocal = 0} prim prim stub ignore assert all zero_alloc @@ -88,16 +93,17 @@ (function {nlocal = 0} prim[addrarray] stub ignore assert all zero_alloc : int (array.length[addr] prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub - ignore assert all zero_alloc : int32 (array.get[addr] prim prim)) + ignore assert all zero_alloc : int32 + (array.get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub ignore assert all zero_alloc : int32 - (array.unsafe_get[addr] prim prim)) + (array.unsafe_get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim[int32] stub ignore assert all zero_alloc : int - (array.set[addr] prim prim prim)) + (array.set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim[int32] stub ignore assert all zero_alloc : int - (array.unsafe_set[addr] prim prim prim)) + (array.unsafe_set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim[int32] prim[int32] stub ignore assert all zero_alloc : int (compare_bints int32 prim prim)) (function {nlocal = 0} prim[int32] prim[int32] stub @@ -116,16 +122,17 @@ (function {nlocal = 0} prim[addrarray] stub ignore assert all zero_alloc : int (array.length[addr] prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub - ignore assert all zero_alloc : int64 (array.get[addr] prim prim)) + ignore assert all zero_alloc : int64 + (array.get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub ignore assert all zero_alloc : int64 - (array.unsafe_get[addr] prim prim)) + (array.unsafe_get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim[int64] stub ignore assert all zero_alloc : int - (array.set[addr] prim prim prim)) + (array.set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim[int64] stub ignore assert all zero_alloc : int - (array.unsafe_set[addr] prim prim prim)) + (array.unsafe_set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim[int64] prim[int64] stub ignore assert all zero_alloc : int (compare_bints int64 prim prim)) (function {nlocal = 0} prim[int64] prim[int64] stub @@ -145,16 +152,16 @@ ignore assert all zero_alloc : int (array.length[addr] prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub ignore assert all zero_alloc : nativeint - (array.get[addr] prim prim)) + (array.get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] stub ignore assert all zero_alloc : nativeint - (array.unsafe_get[addr] prim prim)) + (array.unsafe_get[addr indexed by int] prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim[nativeint] stub ignore assert all zero_alloc : int - (array.set[addr] prim prim prim)) + (array.set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim[addrarray] prim[int] prim[nativeint] stub ignore assert all zero_alloc : int - (array.unsafe_set[addr] prim prim prim)) + (array.unsafe_set[addr indexed by int] prim prim prim)) (function {nlocal = 0} prim[nativeint] prim[nativeint] stub ignore assert all zero_alloc : int (compare_bints nativeint prim prim)) diff --git a/testsuite/tests/typing-layouts/unboxed_int_array_indexing.ml b/testsuite/tests/typing-layouts/unboxed_int_array_indexing.ml new file mode 100644 index 00000000000..84138efa0d8 --- /dev/null +++ b/testsuite/tests/typing-layouts/unboxed_int_array_indexing.ml @@ -0,0 +1,155 @@ +(* TEST + * flambda2 + ** native + ** bytecode + ** native + flags = "-extension layouts_alpha" + ** bytecode + flags = "-extension layouts_alpha" + ** native + flags = "-extension layouts_beta" + ** bytecode + flags = "-extension layouts_beta" +*) + +module By_int64_u = struct + module I = Stdlib__Int64_u + module A = struct + external get : 'a array -> int64# -> 'a = + "%array_safe_get_indexed_by_int64#" + external set : 'a array -> int64# -> 'a -> unit = + "%array_safe_set_indexed_by_int64#" + external unsafe_get : 'a array -> int64# -> 'a = + "%array_unsafe_get_indexed_by_int64#" + external unsafe_set : 'a array -> int64# -> 'a -> unit = + "%array_unsafe_set_indexed_by_int64#" + end +end + +module By_int32_u = struct + module I = Stdlib__Int32_u + module A = struct + external get : 'a array -> int32# -> 'a = + "%array_safe_get_indexed_by_int32#" + external set : 'a array -> int32# -> 'a -> unit = + "%array_safe_set_indexed_by_int32#" + external unsafe_get : 'a array -> int32# -> 'a = + "%array_unsafe_get_indexed_by_int32#" + external unsafe_set : 'a array -> int32# -> 'a -> unit = + "%array_unsafe_set_indexed_by_int32#" + end +end + +module By_nativeint_u = struct + module I = Stdlib__Nativeint_u + + module A = struct + external get : 'a array -> nativeint# -> 'a = + "%array_safe_get_indexed_by_nativeint#" + external set : 'a array -> nativeint# -> 'a -> unit = + "%array_safe_set_indexed_by_nativeint#" + external unsafe_get : 'a array -> nativeint# -> 'a = + "%array_unsafe_get_indexed_by_nativeint#" + external unsafe_set : 'a array -> nativeint# -> 'a -> unit = + "%array_unsafe_set_indexed_by_nativeint#" + end +end + +let check_eq arr g = + for i = 0 to Array.length arr - 1 do + assert (g arr i = arr.(i)) + done + +let check_inval f = + try f (); assert false with + | Invalid_argument _ -> () + +let pp = Format.printf + +let test_get (g: 'a. 'a array -> int -> 'a) = + check_eq [| 1; 2; 3; 4; 5; 6; 7|] g; + check_eq [| "a"; "b"; "c"; "d"|] g; + check_eq [| 1.; 2.; 3.; 4.; 5.|] g; + () + +let test_set (g: 'a. 'a array -> int -> 'a -> unit) = + let fill arr v = + for i = 0 to Array.length arr - 1 do + g arr i v; assert(Array.get arr i = v) + done + in + let check_all_eq arr v = assert (Array.for_all (fun x -> x = v) arr) in + let arr = [| 1; 2; 3; 4; 5; 6; 7|] in + fill arr 0; check_all_eq arr 0; + let arr = [| "a"; "b"; "c"; "d"|] in + fill arr "aaa"; check_all_eq arr "aaa"; + let arr = [| 1.; 2.; 3.; 4.; 5.|] in + fill arr 0.; check_all_eq arr 0.; + () + +let test_int64_u () = + let open By_int64_u in + + test_get (fun arr i -> A.get arr (I.of_int i)); + test_get (fun arr i -> A.unsafe_get arr (I.of_int i)); + + test_set (fun arr i -> A.set arr (I.of_int i)); + test_set (fun arr i -> A.unsafe_set arr (I.of_int i)); + + (* This is + 0b1000000000000000000000000000000000000000000000000000000000000001 + in binary and should be out of bound. *) + check_inval (fun () -> A.get [| 1; 2; 3|] (-#9223372036854775807L)); + check_inval (fun () -> A.set [| 1; 2; 3|] (-#9223372036854775807L) 0); + (* no promises when using unsafe_get. int truncation happens. *) + let arr = [| 1; 2; 3|] in + assert (A.unsafe_get arr (-#9223372036854775807L) = 2); + A.unsafe_set arr (-#9223372036854775807L) 11111; + assert (A.unsafe_get arr #1L = 11111); + check_inval (fun () -> A.get [| 1; 2; 3|] (-#1L)); + check_inval (fun () -> A.set [| 1; 2; 3|] (-#1L) 1); + () + +let test_int32_u () = + let open By_int32_u in + + test_get (fun arr i -> A.get arr (I.of_int i)); + test_get (fun arr i -> A.unsafe_get arr (I.of_int i)); + + test_set (fun arr i -> A.set arr (I.of_int i)); + test_set (fun arr i -> A.unsafe_set arr (I.of_int i)); + + check_inval (fun () -> A.get [| 1; 2; 3|] (-#2147483647l)); + check_inval (fun () -> A.set [| 1; 2; 3|] (-#2147483647l) 0); + check_inval (fun () -> A.get [| 1; 2; 3|] (-#1l)); + check_inval (fun () -> A.set [| 1; 2; 3|] (-#1l) 1); + () + +let test_nativeint_u () = + let open By_nativeint_u in + + test_get (fun arr i -> A.get arr (I.of_int i)); + test_get (fun arr i -> A.unsafe_get arr (I.of_int i)); + + test_set (fun arr i -> A.set arr (I.of_int i)); + test_set (fun arr i -> A.unsafe_set arr (I.of_int i)); + + (* This is + 0b1000000000000000000000000000000000000000000000000000000000000001 + in binary and should be out of bound. *) + check_inval (fun () -> A.get [| 1; 2; 3|] (-#9223372036854775807n)); + check_inval (fun () -> A.set [| 1; 2; 3|] (-#9223372036854775807n) 0); + (* no promises when using unsafe_get. int truncation happens. *) + let arr = [| 1; 2; 3|] in + assert (A.unsafe_get arr (-#9223372036854775807n) = 2); + A.unsafe_set arr (-#9223372036854775807n) 11111; + assert (A.unsafe_get arr #1n = 11111); + check_inval (fun () -> A.get [| 1; 2; 3|] (-#1n)); + check_inval (fun () -> A.set [| 1; 2; 3|] (-#1n) 1); + () + +let () = + test_int64_u (); + test_int32_u (); + test_nativeint_u (); + () diff --git a/testsuite/tests/typing-layouts/unboxed_int_array_indexing.reference b/testsuite/tests/typing-layouts/unboxed_int_array_indexing.reference new file mode 100644 index 00000000000..e69de29bb2d diff --git a/typing/primitive.ml b/typing/primitive.ml index 4cd85a89757..f99ba950003 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -517,6 +517,73 @@ let prim_has_valid_reprs ~loc prim = any; is (Same_as_ocaml_repr Value)] + | "%array_safe_get_indexed_by_int64#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits64); + any] + | "%array_safe_set_indexed_by_int64#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits64); + any; + is (Same_as_ocaml_repr Value)] + | "%array_unsafe_get_indexed_by_int64#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits64); + any] + | "%array_unsafe_set_indexed_by_int64#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits64); + any; + is (Same_as_ocaml_repr Value)] + | "%array_safe_get_indexed_by_int32#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits32); + any] + | "%array_safe_set_indexed_by_int32#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits32); + any; + is (Same_as_ocaml_repr Value)] + | "%array_unsafe_get_indexed_by_int32#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits32); + any] + | "%array_unsafe_set_indexed_by_int32#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Bits32); + any; + is (Same_as_ocaml_repr Value)] + | "%array_safe_get_indexed_by_nativeint#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Word); + any] + | "%array_safe_set_indexed_by_nativeint#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Word); + any; + is (Same_as_ocaml_repr Value)] + | "%array_unsafe_get_indexed_by_nativeint#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Word); + any] + | "%array_unsafe_set_indexed_by_nativeint#" -> + check [ + is (Same_as_ocaml_repr Value); + is (Same_as_ocaml_repr Word); + any; + is (Same_as_ocaml_repr Value)] + | "%box_float" -> exactly [Same_as_ocaml_repr Float64; Same_as_ocaml_repr Value] | "%unbox_float" -> @@ -565,7 +632,19 @@ let prim_can_contain_jkind_any prim = | "%array_safe_get" | "%array_safe_set" | "%array_unsafe_get" - | "%array_unsafe_set" -> false + | "%array_unsafe_set" + | "%array_safe_get_indexed_by_int64#" + | "%array_safe_set_indexed_by_int64#" + | "%array_unsafe_get_indexed_by_int64#" + | "%array_unsafe_set_indexed_by_int64#" + | "%array_safe_get_indexed_by_int32#" + | "%array_safe_set_indexed_by_int32#" + | "%array_unsafe_get_indexed_by_int32#" + | "%array_unsafe_set_indexed_by_int32#" + | "%array_safe_get_indexed_by_nativeint#" + | "%array_safe_set_indexed_by_nativeint#" + | "%array_unsafe_get_indexed_by_nativeint#" + | "%array_unsafe_set_indexed_by_nativeint#" -> false | _ -> true let report_error ppf err =