Specialize Sys.max_array_length for arrays of unboxed numbers

ocaml/runtime/array.c

@@ -28,6 +28,13 @@
 
 static const mlsize_t mlsize_t_max = -1;
 
+#define Max_array_wosize                   (Max_wosize)
+#define Max_custom_array_wosize            (Max_wosize - 1)
+#define Max_unboxed_float_array_wosize     (Max_array_wosize / (sizeof(double) / sizeof(intnat)))
+#define Max_unboxed_int64_array_wosize     (Max_custom_array_wosize / (sizeof(int64_t) / sizeof(intnat)))
+#define Max_unboxed_int32_array_wosize     (Max_custom_array_wosize * (sizeof(intnat) / sizeof(int32_t)))
+#define Max_unboxed_nativeint_array_wosize (Max_custom_array_wosize)
+
 /* Unboxed arrays */
 
 CAMLprim int caml_unboxed_array_no_polymorphic_compare(value v1, value v2)
@@ -377,7 +384,7 @@ CAMLprim value caml_floatarray_create(value len)
       return Atom(0);
     else
       Alloc_small (result, wosize, Double_array_tag, Alloc_small_enter_GC);
-  }else if (wosize > Max_wosize)
+  }else if (wosize > Max_unboxed_float_array_wosize)
     caml_invalid_argument("Float.Array.create");
   else {
     result = caml_alloc_shr (wosize, Double_array_tag);
@@ -408,8 +415,8 @@ static value make_vect_gen(value len, value init, int local)
     mlsize_t wsize;
     double d;
     d = Double_val(init);
+    if (size > Max_unboxed_float_array_wosize) caml_invalid_argument("Array.make");
     wsize = size * Double_wosize;
-    if (wsize > Max_wosize) caml_invalid_argument("Array.make");
     res = local ?
       caml_alloc_local(wsize, Double_array_tag) :
       caml_alloc(wsize, Double_array_tag);
@@ -418,7 +425,7 @@ static value make_vect_gen(value len, value init, int local)
     }
 #endif
   } else {
-    if (size > Max_wosize) caml_invalid_argument("Array.make");
+    if (size > Max_array_wosize) caml_invalid_argument("Array.make");
     else if (local) {
       res = caml_alloc_local(size, 0);
       for (i = 0; i < size; i++) Field(res, i) = init;
@@ -483,10 +490,10 @@ CAMLprim value caml_make_unboxed_int32_vect(value len)
   /* This is only used on 64-bit targets. */
 
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_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 + 1) / 2;
+  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);
@@ -500,7 +507,7 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len)
 CAMLprim value caml_make_unboxed_int64_vect(value len)
 {
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_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;
 
@@ -517,7 +524,7 @@ CAMLprim value caml_make_unboxed_nativeint_vect(value len)
   /* This is only used on 64-bit targets. */
 
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_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;
 
@@ -748,7 +755,7 @@ static value caml_array_gather(intnat num_arrays,
 #ifdef FLAT_FLOAT_ARRAY
   else if (isfloat) {
     /* This is an array of floats.  We can use memcpy directly. */
-    if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat");
+    if (size > Max_unboxed_float_array_wosize) caml_invalid_argument("Array.concat");
     wsize = size * Double_wosize;
     res = local ?
       caml_alloc_local(wsize, Double_array_tag) :
@@ -764,7 +771,7 @@ static value caml_array_gather(intnat num_arrays,
     CAMLassert(pos == size);
   }
 #endif
-  else if (size > Max_wosize) {
+  else if (size > Max_array_wosize) {
     /* Array of values, too big. */
     caml_invalid_argument("Array.concat");
   } else if (size <= Max_young_wosize || local) {

ocaml/runtime/float32.c

@@ -61,6 +61,9 @@
 
 CAML_STATIC_ASSERT(sizeof(float) == sizeof(int32_t));
 
+#define Max_custom_array_wosize          (Max_wosize - 1)
+#define Max_unboxed_float32_array_wosize (Max_custom_array_wosize * (sizeof(intnat) / sizeof(float)))
+
 intnat caml_float32_compare_unboxed(float f, float g)
 {
   /* If one or both of f and g is NaN, order according to the convention
@@ -574,10 +577,10 @@ CAMLprim value caml_make_unboxed_float32_vect(value len)
   /* This is only used on 64-bit targets. */
 
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_wosize) caml_invalid_argument("Array.make");
+  if (num_elements > Max_unboxed_float32_array_wosize) caml_invalid_argument("Array.make");
 
   /* [num_fields] does not include the custom operations field. */
-  mlsize_t num_fields = (num_elements + 1) / 2;
+  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);

ocaml/runtime4/array.c

@@ -28,6 +28,13 @@
 
 static const mlsize_t mlsize_t_max = -1;
 
+#define Max_array_wosize                   (Max_wosize)
+#define Max_custom_array_wosize            (Max_wosize - 1)
+#define Max_unboxed_float_array_wosize     (Max_array_wosize / (sizeof(double) / sizeof(intnat)))
+#define Max_unboxed_int64_array_wosize     (Max_custom_array_wosize / (sizeof(int64_t) / sizeof(intnat)))
+#define Max_unboxed_int32_array_wosize     (Max_custom_array_wosize * (sizeof(intnat) / sizeof(int32_t)))
+#define Max_unboxed_nativeint_array_wosize (Max_custom_array_wosize)
+
 /* Unboxed arrays */
 
 CAMLprim int caml_unboxed_array_no_polymorphic_compare(value v1, value v2)
@@ -385,7 +392,7 @@ CAMLprim value caml_floatarray_create(value len)
       Alloc_small (result, wosize, Double_array_tag);
 #undef Setup_for_gc
 #undef Restore_after_gc
-  }else if (wosize > Max_wosize)
+  }else if (wosize > Max_unboxed_float_array_wosize)
     caml_invalid_argument("Float.Array.create");
   else {
     result = caml_alloc_shr (wosize, Double_array_tag);
@@ -417,8 +424,8 @@ static value make_vect_gen(value len, value init, int local)
     mlsize_t wsize;
     double d;
     d = Double_val(init);
+    if (size > Max_unboxed_float_array_wosize) caml_invalid_argument("Array.make");
     wsize = size * Double_wosize;
-    if (wsize > Max_wosize) caml_invalid_argument("Array.make");
     res = local ?
       caml_alloc_local(wsize, Double_array_tag) :
       caml_alloc(wsize, Double_array_tag);
@@ -427,7 +434,7 @@ static value make_vect_gen(value len, value init, int local)
     }
 #endif
   } else {
-    if (size > Max_wosize) caml_invalid_argument("Array.make");
+    if (size > Max_array_wosize) caml_invalid_argument("Array.make");
     else if (local) {
       res = caml_alloc_local(size, 0);
       for (i = 0; i < size; i++) Field(res, i) = init;
@@ -485,10 +492,10 @@ CAMLprim value caml_make_unboxed_int32_vect(value len)
   /* This is only used on 64-bit targets. */
 
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_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 + 1) / 2;
+  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);
@@ -502,14 +509,13 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len)
 CAMLprim value caml_make_unboxed_int64_vect(value len)
 {
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_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);
 }
 
-
 CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len)
 {
   return caml_make_vect(len, caml_copy_int64(0));
@@ -520,7 +526,7 @@ CAMLprim value caml_make_unboxed_nativeint_vect(value len)
   /* This is only used on 64-bit targets. */
 
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_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;
 
@@ -709,7 +715,7 @@ static value caml_array_gather(intnat num_arrays,
 #ifdef FLAT_FLOAT_ARRAY
   else if (isfloat) {
     /* This is an array of floats.  We can use memcpy directly. */
-    if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat");
+    if (size > Max_unboxed_float_array_wosize) caml_invalid_argument("Array.concat");
     wsize = size * Double_wosize;
     res = local ?
       caml_alloc_local(wsize, Double_array_tag) :
@@ -723,7 +729,7 @@ static value caml_array_gather(intnat num_arrays,
     CAMLassert(pos == size);
   }
 #endif
-  else if (size > Max_wosize) {
+  else if (size > Max_array_wosize) {
     /* Array of values, too big. */
     caml_invalid_argument("Array.concat");
   } else if (size <= Max_young_wosize || local) {

ocaml/runtime4/float32.c

@@ -61,6 +61,9 @@
 
 CAML_STATIC_ASSERT(sizeof(float) == sizeof(int32_t));
 
+#define Max_custom_array_wosize          (Max_wosize - 1)
+#define Max_unboxed_float32_array_wosize (Max_custom_array_wosize * (sizeof(intnat) / sizeof(float)))
+
 intnat caml_float32_compare_unboxed(float f, float g)
 {
   /* If one or both of f and g is NaN, order according to the convention
@@ -574,10 +577,10 @@ CAMLprim value caml_make_unboxed_float32_vect(value len)
   /* This is only used on 64-bit targets. */
 
   mlsize_t num_elements = Long_val(len);
-  if (num_elements > Max_wosize) caml_invalid_argument("Array.make");
+  if (num_elements > Max_unboxed_float32_array_wosize) caml_invalid_argument("Array.make");
 
   /* [num_fields] does not include the custom operations field. */
-  mlsize_t num_fields = (num_elements + 1) / 2;
+  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);

ocaml/stdlib/sys.ml.in

@@ -47,6 +47,33 @@ let cygwin = cygwin ()
 let max_array_length = max_wosize ()
 let max_floatarray_length = max_array_length / (64 / word_size)
 let max_string_length = word_size / 8 * max_array_length - 1
+
+(* In bytecode, [float# array] is treated as [float array].
+   Using [max_floatarray_length] assumes flat float arrays are enabled. *)
+let max_unboxed_float_array_length = max_floatarray_length
+
+let max_custom_array_length = max_array_length - 1
+
+let max_unboxed_float32_array_length =
+  match backend_type with
+  | Native -> max_custom_array_length * (word_size / 32)
+  | Bytecode | Other _ -> max_array_length
+
+let max_unboxed_int64_array_length =
+  match backend_type with
+  | Native -> max_custom_array_length / (64 / word_size)
+  | Bytecode | Other _ -> max_array_length
+
+let max_unboxed_int32_array_length =
+  match backend_type with
+  | Native -> max_custom_array_length * (word_size / 32)
+  | Bytecode | Other _ -> max_array_length
+
+let max_unboxed_nativeint_array_length =
+  match backend_type with
+  | Native -> max_custom_array_length
+  | Bytecode | Other _ -> max_array_length
+
 external runtime_variant : unit -> string = "caml_runtime_variant"
 external runtime_parameters : unit -> string = "caml_runtime_parameters"
 

ocaml/stdlib/sys.mli

@@ -190,7 +190,7 @@ val max_string_length : int
 
 val max_array_length : int
 (** Maximum length of a normal array (i.e. any array whose elements are
-    not of type [float]). The maximum length of a [float array]
+    not unboxed and not of type [float]). The maximum length of a [float array]
     is [max_floatarray_length] if OCaml was configured with
     [--enable-flat-float-array] and [max_array_length] if configured
     with [--disable-flat-float-array]. *)
@@ -200,6 +200,26 @@ val max_floatarray_length : int
     a [float array] when OCaml is configured with
     [--enable-flat-float-array]. *)
 
+val max_unboxed_float_array_length : int
+(** Maximum length of a [float# array].
+    Equivalent to [max_floatarray_length]. *)
+
+val max_unboxed_float32_array_length : int
+(** Maximum length of a [float32# array].
+    In non-native backends, equal to [max_array_length]. *)
+
+val max_unboxed_int64_array_length : int
+(** Maximum length of a [int64# array].
+    In non-native backends, equal to [max_array_length]. *)
+
+val max_unboxed_int32_array_length : int
+(** Maximum length of a [int32# array].
+    In non-native backends, equal to [max_array_length]. *)
+
+val max_unboxed_nativeint_array_length : int
+(** Maximum length of a [nativeint# array].
+    In non-native backends, equal to [max_array_length]. *)
+
 external runtime_variant : unit -> string = "caml_runtime_variant"
 (** Return the name of the runtime variant the program is running on.
     This is normally the argument given to [-runtime-variant] at compile

ocaml/testsuite/tests/typing-layouts-arrays/gen_u_array.ml

@@ -30,6 +30,7 @@ module type S0 = sig
     t -> int -> t -> int -> int -> unit
   val empty : unit -> t
   val compare_element: element_arg -> element_arg -> int
+  val max_length : int
 end
 
 
@@ -48,7 +49,6 @@ module type S = sig
   *   [@@ocaml.deprecated
   *     "Use Array.create_float/ArrayLabels.create_float instead."] *)
 
-
   val init : int -> (int -> element_arg) -> t
   val make_matrix : int -> int -> element_arg -> t array
   val create_matrix : int -> int -> element_arg -> t array

ocaml/testsuite/tests/typing-layouts-arrays/test_float32_u_array.ml

@@ -48,6 +48,7 @@ module Float32_u_array0 : Gen_u_array.S0
   type ('a : any) array_t = 'a array
   type element_arg = unit -> element_t
   type t = element_t array
+  let max_length = Sys.max_unboxed_float32_array_length
   external length : ('a : float32). 'a array -> int = "%array_length"
   external get: ('a : float32). 'a array -> int -> 'a = "%array_safe_get"
   let get t i = let a = get t i in fun () -> a

ocaml/testsuite/tests/typing-layouts-arrays/test_gen_u_array.ml

@@ -130,7 +130,7 @@ end) : S with type t = Arg.M.t
     let res = make len (of_boxed (I.of_int 0)) in
     List.iteri (fun idx f -> set res idx (of_boxed f)) l;
     res
-  let max_length = Sys.max_array_length
+
   let get t idx = to_boxed (get t idx)
   let set t idx v = set t idx (of_boxed v)
 

ocaml/testsuite/tests/typing-layouts-arrays/test_int32_u_array.ml

@@ -46,6 +46,7 @@ module Int32_u_array0 : Gen_u_array.S0
   type ('a : any) array_t = 'a array
   type element_arg = unit -> element_t
   type t = element_t array
+  let max_length = Sys.max_unboxed_int32_array_length
   external length : ('a : bits32). 'a array -> int = "%array_length"
   external get: ('a : bits32). 'a array -> int -> 'a = "%array_safe_get"
   let get t i = let a = get t i in fun () -> a

ocaml/testsuite/tests/typing-layouts-arrays/test_int64_u_array.ml

@@ -46,6 +46,7 @@ module Int64_u_array0 : Gen_u_array.S0
   type ('a : any) array_t = 'a array
   type element_arg = unit -> element_t
   type t = element_t array
+  let max_length = Sys.max_unboxed_int64_array_length
   external length : ('a : bits64). 'a array -> int = "%array_length"
   external get: ('a : bits64). 'a array -> int -> 'a = "%array_safe_get"
   let get t i = let a = get t i in fun () -> a

ocaml/testsuite/tests/typing-layouts-arrays/test_nativeint_u_array.ml

@@ -47,6 +47,7 @@ module Nativeint_u_array0 : Gen_u_array.S0
   type ('a : any) array_t = 'a array
   type element_arg = unit -> element_t
   type t = element_t array
+  let max_length = Sys.max_unboxed_nativeint_array_length
   external length : ('a : word). 'a array -> int = "%array_length"
   external get: ('a : word). 'a array -> int -> 'a = "%array_safe_get"
   let get t i = let a = get t i in fun () -> a

ocaml/testsuite/tests/typing-layouts-arrays/test_stdlib_float_u_array.ml

@@ -84,7 +84,9 @@ module Float_array : S = struct
   let map_from_array f a = map f a
   let mem_ieee x a = exists ((=) x) a
   type t = float array
-  let max_length = Sys.max_array_length
+
+  (* This test assumes flat float arrays are enabled. *)
+  let max_length = Sys.max_floatarray_length
 end
 
 module Test_float_u_array : S = struct
@@ -142,7 +144,9 @@ module Test_float_u_array : S = struct
     let res = create len in
     List.iteri (fun idx f -> set res idx (of_float f)) l;
     res
-  let max_length = Sys.max_floatarray_length
+
+  let max_length = Sys.max_unboxed_float_array_length
+
   let get t idx = to_float (get t idx)
   let set t idx v = set t idx (of_float v)