Determine unboxed int32 array length using custom_ops index

backend/amd64/emit.mlp

@@ -1918,6 +1918,9 @@ let emit_item = function
   | Csymbol_address s ->
     add_used_symbol s.sym_name;
     D.qword (ConstLabel (emit_cmm_symbol s))
+  | Csymbol_offset (s, o) ->
+    add_used_symbol s.sym_name;
+    D.qword (ConstLabelOffset (emit_cmm_symbol s, o))
   | Cstring s -> D.bytes s
   | Cskip n -> if n > 0 then D.space n
   | Calign n -> D.align ~data:true n

backend/arm64/emit.mlp

@@ -1200,6 +1200,7 @@ let emit_item = function
     (* CR mslater: (SIMD) arm64 *)
     Misc.fatal_error "128-bit vectors not supported on this architecture"
   | Csymbol_address s -> `	.quad	{emit_symbol s.sym_name}\n`
+  | Csymbol_offset (s, o) -> `	.quad	{emit_symbol s.sym_name}+{emit_int o}\n`
   | Cstring s -> emit_string_directive "	.ascii  " s
   | Cskip n -> if n > 0 then `	.space	{emit_int n}\n`
   | Calign n -> `	.align	{emit_int(Misc.log2 n)}\n`

backend/cmm.ml

@@ -324,6 +324,7 @@ type data_item =
   | Cdouble of float
   | Cvec128 of vec128_bits
   | Csymbol_address of symbol
+  | Csymbol_offset of symbol * int
   | Cstring of string
   | Cskip of int
   | Calign of int

backend/cmm.mli

@@ -332,6 +332,7 @@ type data_item =
   | Cdouble of float
   | Cvec128 of vec128_bits
   | Csymbol_address of symbol
+  | Csymbol_offset of symbol * int
   | Cstring of string
   | Cskip of int
   | Calign of int

backend/cmm_helpers.ml

@@ -891,13 +891,26 @@ let array_indexing ?typ log2size ptr ofs dbg =
    cross-compiling for 64-bit on a 32-bit host *)
 let int ~dbg i = natint_const_untagged dbg (Nativeint.of_int i)
 
-let custom_ops_unboxed_int32_odd_array =
+let custom_ops_size_log2 =
+  let lg = Misc.log2 Config.custom_ops_struct_size in
+  assert (1 lsl lg = Config.custom_ops_struct_size);
+  lg
+
+(* caml_unboxed_int32_array_ops refers to the first element of an array of two
+   custom ops. The array index indicates the number of (invalid) tailing int32s
+   (0 or 1). *)
+let custom_ops_unboxed_int32_array =
   Cconst_symbol
-    (Cmm.global_symbol "caml_unboxed_int32_odd_array_ops", Debuginfo.none)
+    (Cmm.global_symbol "caml_unboxed_int32_array_ops", Debuginfo.none)
 
-let custom_ops_unboxed_int32_even_array =
-  Cconst_symbol
-    (Cmm.global_symbol "caml_unboxed_int32_even_array_ops", Debuginfo.none)
+let custom_ops_unboxed_int32_even_array = custom_ops_unboxed_int32_array
+
+let custom_ops_unboxed_int32_odd_array =
+  Cop
+    ( Caddi,
+      [ custom_ops_unboxed_int32_array;
+        Cconst_int (Config.custom_ops_struct_size, Debuginfo.none) ],
+      Debuginfo.none )
 
 let custom_ops_unboxed_int64_array =
   Cconst_symbol
@@ -908,36 +921,34 @@ let custom_ops_unboxed_nativeint_array =
     (Cmm.global_symbol "caml_unboxed_nativeint_array_ops", Debuginfo.none)
 
 let unboxed_int32_array_length arr dbg =
-  (* A dynamic test is needed to determine if the array contains an odd or even
-     number of elements *)
+  (* Checking custom_ops is needed to determine if the array contains an odd or
+     even number of elements *)
   let res =
     bind "arr" arr (fun arr ->
         let custom_ops_var = Backend_var.create_local "custom_ops" in
+        let custom_ops_index_var =
+          Backend_var.create_local "custom_ops_index"
+        in
         let num_words_var = Backend_var.create_local "num_words" in
         Clet
           ( VP.create num_words_var,
-            (* need to subtract so as not to count the custom_operations
-               field *)
+            (* subtract custom_operations word *)
             sub_int (get_size arr dbg) (int ~dbg 1) dbg,
             Clet
               ( VP.create custom_ops_var,
                 Cop (mk_load_immut Word_int, [arr], dbg),
-                Cifthenelse
-                  ( Cop
-                      ( Ccmpa Ceq,
-                        [Cvar custom_ops_var; custom_ops_unboxed_int32_odd_array],
-                        dbg ),
-                    dbg,
-                    (* unboxed int32 odd *)
-                    (sub_int
-                       (mul_int (Cvar num_words_var) (int ~dbg 2) dbg)
-                       (int ~dbg 1))
+                Clet
+                  ( VP.create custom_ops_index_var,
+                    (* compute index into custom ops array *)
+                    lsr_int
+                      (sub_int (Cvar custom_ops_var)
+                         custom_ops_unboxed_int32_array dbg)
+                      (int ~dbg custom_ops_size_log2)
                       dbg,
-                    dbg,
-                    (* assumed to be unboxed int32 even *)
-                    mul_int (Cvar num_words_var) (int ~dbg 2) dbg,
-                    dbg,
-                    Any ) ) ))
+                    (* subtract index from length in int32s *)
+                    sub_int
+                      (mul_int (Cvar num_words_var) (int ~dbg 2) dbg)
+                      (Cvar custom_ops_index_var) dbg ) ) ))
   in
   tag_int res dbg
 
@@ -3542,6 +3553,8 @@ let cvec128 bits = Cmm.Cvec128 bits
 
 let symbol_address s = Cmm.Csymbol_address s
 
+let symbol_offset s o = Cmm.Csymbol_offset (s, o)
+
 let define_symbol symbol = [Cdefine_symbol symbol]
 
 (* Cmm phrases *)

backend/cmm_helpers.mli

@@ -815,6 +815,8 @@ val cvec128 : Cmm.vec128_bits -> data_item
 (** Static symbol. *)
 val symbol_address : symbol -> data_item
 
+val symbol_offset : symbol -> int -> data_item
+
 (** Definition for a static symbol. *)
 val define_symbol : symbol -> data_item list
 

backend/printcmm.ml

@@ -423,6 +423,7 @@ let data_item ppf = function
   | Cvec128 {high; low} ->
     fprintf ppf "vec128 %s:%s" (Int64.to_string high) (Int64.to_string low)
   | Csymbol_address s -> fprintf ppf "addr %a:\"%s\"" is_global s.sym_global s.sym_name
+  | Csymbol_offset (s, o) -> fprintf ppf "addr %a:\"%s+%d\"" is_global s.sym_global s.sym_name o
   | Cstring s -> fprintf ppf "string \"%s\"" s
   | Cskip n -> fprintf ppf "skip %i" n
   | Calign n -> fprintf ppf "align %i" n

backend/x86_ast.mli

@@ -46,6 +46,7 @@ type constant =
   | Const of int64
   | ConstThis
   | ConstLabel of string
+  | ConstLabelOffset of string * int
   | ConstAdd of constant * constant
   | ConstSub of constant * constant
 

backend/x86_binary_emitter.ml

@@ -190,6 +190,7 @@ let eval_const b current_pos cst =
     | Const n -> Rint n
     | ConstThis -> Rabs ("", 0L)
     | ConstLabel lbl -> Rabs (lbl, 0L)
+    | ConstLabelOffset (lbl, o) -> Rabs (lbl, Int64.of_int o)
     | ConstSub (c1, c2) -> (
         let c1 = eval c1 and c2 = eval c2 in
         match (c1, c2) with

backend/x86_gas.ml

@@ -69,13 +69,14 @@ let arg b = function
   | Mem64_RIP (_, s, displ) -> bprintf b "%s%a(%%rip)" s opt_displ displ
 
 let rec cst b = function
-  | ConstLabel _ | Const _ | ConstThis as c -> scst b c
+  | ConstLabel _ | ConstLabelOffset _ | Const _ | ConstThis as c -> scst b c
   | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2
   | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2
 
 and scst b = function
   | ConstThis -> Buffer.add_string b "."
   | ConstLabel l -> Buffer.add_string b l
+  | ConstLabelOffset (l, o) -> Buffer.add_string b l; opt_displ b o
   | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L ->
       Buffer.add_string b (Int64.to_string n)
   | Const n -> bprintf b "0x%Lx" n

backend/x86_masm.ml

@@ -93,13 +93,17 @@ let arg b = function
   | Mem addr -> arg_mem b addr
 
 let rec cst b = function
-  | ConstLabel _ | Const _ | ConstThis as c -> scst b c
+  | ConstLabel _ | ConstLabelOffset _  | Const _ | ConstThis as c -> scst b c
   | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2
   | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2
 
 and scst b = function
   | ConstThis -> Buffer.add_string b "THIS BYTE"
   | ConstLabel l -> Buffer.add_string b l
+  | ConstLabelOffset (l, o) ->
+      Buffer.add_string b l;
+      if o > 0 then bprintf b "+%d" o
+      else if o < 0 then bprintf b "%d" o
   | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L ->
       Buffer.add_string b (Int64.to_string n)
   | Const n -> bprintf b "0%LxH" n

middle_end/flambda2/to_cmm/to_cmm_result.ml

@@ -96,7 +96,7 @@ let defines_a_symbol data =
   match (data : Cmm.data_item) with
   | Cdefine_symbol _ -> true
   | Cint8 _ | Cint16 _ | Cint32 _ | Cint _ | Csingle _ | Cdouble _ | Cvec128 _
-  | Csymbol_address _ | Cstring _ | Cskip _ | Calign _ ->
+  | Csymbol_address _ | Csymbol_offset _ | Cstring _ | Cskip _ | Calign _ ->
     false
 
 let add_to_data_list x l =

middle_end/flambda2/to_cmm/to_cmm_static.ml

@@ -161,7 +161,13 @@ let immutable_unboxed_int_array env res updates update_kind ~symbol ~elts
       ~size:(1 (* for the custom_operations pointer *) + num_fields)
   in
   let static_fields =
-    C.symbol_address (Cmm.global_symbol (custom_ops_symbol ~num_elts))
+    let sym_base, sym_off = custom_ops_symbol ~num_elts in
+    let address =
+      match sym_off with
+      | None -> C.symbol_address (Cmm.global_symbol sym_base)
+      | Some sym_off -> C.symbol_offset (Cmm.global_symbol sym_base) sym_off
+    in
+    address
     :: immutable_unboxed_int_array_payload update_kind num_fields ~elts
          ~to_int64
   in
@@ -260,17 +266,16 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t)
     assert (Arch.size_int = 8);
     immutable_unboxed_int_array env res updates Int32 ~symbol ~elts
       ~to_int64:Int64.of_int32 ~custom_ops_symbol:(fun ~num_elts ->
-        if num_elts mod 2 = 0
-        then "caml_unboxed_int32_even_array_ops"
-        else "caml_unboxed_int32_odd_array_ops")
+        ( "caml_unboxed_int32_array_ops",
+          Some (Config.custom_ops_struct_size * (num_elts mod 2)) ))
   | Block_like symbol, Immutable_int64_array elts ->
     immutable_unboxed_int_array env res updates Int64_or_nativeint ~symbol ~elts
       ~to_int64:Fun.id ~custom_ops_symbol:(fun ~num_elts:_ ->
-        "caml_unboxed_int64_array_ops")
+        "caml_unboxed_int64_array_ops", None)
   | Block_like symbol, Immutable_nativeint_array elts ->
     immutable_unboxed_int_array env res updates Int64_or_nativeint ~symbol ~elts
       ~to_int64:Targetint_32_64.to_int64 ~custom_ops_symbol:(fun ~num_elts:_ ->
-        "caml_unboxed_nativeint_array_ops")
+        "caml_unboxed_nativeint_array_ops", None)
   | Block_like s, Immutable_value_array fields ->
     let sym = R.symbol res s in
     let header = C.black_block_header 0 (List.length fields) in
@@ -294,8 +299,7 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t)
     let block =
       C.emit_block (R.symbol res s)
         (C.black_custom_header ~size:1)
-        [ C.symbol_address
-            (Cmm.global_symbol "caml_unboxed_int32_even_array_ops") ]
+        [C.symbol_address (Cmm.global_symbol "caml_unboxed_int32_array_ops")]
     in
     env, R.set_data res block, updates
   | Block_like s, Empty_array Naked_int64s ->

ocaml/Makefile.config.in

@@ -218,6 +218,7 @@ WITH_CPP_MANGLING=@cpp_mangling@
 WITH_PROFINFO=@profinfo@
 PROFINFO_WIDTH=@profinfo_width@
 HEADER_RESERVED_BITS=@reserved_header_bits@
+CUSTOM_OPS_STRUCT_SIZE=@custom_ops_struct_size@
 LIBUNWIND_AVAILABLE=@libunwind_available@
 LIBUNWIND_INCLUDE_FLAGS=@libunwind_include_flags@
 LIBUNWIND_LINK_FLAGS=@libunwind_link_flags@

ocaml/configure.ac

@@ -62,6 +62,7 @@ ostype="Unix"
 SO="so"
 toolchain="cc"
 reserved_header_bits=0
+custom_ops_struct_size=64
 instrumented_runtime=false
 instrumented_runtime_libs=""
 bootstrapping_flexdll=false
@@ -204,6 +205,7 @@ AC_SUBST([install_bytecode_programs])
 AC_SUBST([install_source_artifacts])
 AC_SUBST([install_ocamlnat])
 AC_SUBST([reserved_header_bits])
+AC_SUBST([custom_ops_struct_size])
 AC_SUBST([frame_pointers])
 AC_SUBST([cpp_mangling])
 AC_SUBST([flambda])
@@ -2199,6 +2201,7 @@ AS_IF([test x"$enable_naked_pointers_checker" = "xyes" ],
 OCAML_MMAP_SUPPORTS_HUGE_PAGES
 
 AC_DEFINE_UNQUOTED([HEADER_RESERVED_BITS], [$reserved_header_bits])
+AC_DEFINE_UNQUOTED([CUSTOM_OPS_STRUCT_SIZE], [$custom_ops_struct_size])
 
 AS_IF([test x"$enable_installing_bytecode_programs" = "xno"],
   [install_bytecode_programs=false],

ocaml/runtime/array.c

@@ -55,26 +55,23 @@ static uintnat unboxed_array_deserialize(void* dst)
 // the int32 unboxed arrays, care needs to be taken with the last word
 // when the array is of odd length -- this is not currently initialized.
 
-CAMLexport struct custom_operations caml_unboxed_int32_odd_array_ops = {
-  "_unboxed_int32_odd_array",
-  custom_finalize_default,
-  no_polymorphic_compare,
-  no_polymorphic_hash,
-  unboxed_array_serialize,
-  unboxed_array_deserialize,
-  custom_compare_ext_default,
-  custom_fixed_length_default
-};
-
-CAMLexport struct custom_operations caml_unboxed_int32_even_array_ops = {
-  "_unboxed_int32_even_array",
-  custom_finalize_default,
-  no_polymorphic_compare,
-  no_polymorphic_hash,
-  unboxed_array_serialize,
-  unboxed_array_deserialize,
-  custom_compare_ext_default,
-  custom_fixed_length_default
+CAMLexport struct custom_operations caml_unboxed_int32_array_ops[2] = {
+  { "_unboxed_int32_even_array",
+    custom_finalize_default,
+    no_polymorphic_compare,
+    no_polymorphic_hash,
+    unboxed_array_serialize,
+    unboxed_array_deserialize,
+    custom_compare_ext_default,
+    custom_fixed_length_default },
+  { "_unboxed_int32_odd_array",
+    custom_finalize_default,
+    no_polymorphic_compare,
+    no_polymorphic_hash,
+    unboxed_array_serialize,
+    unboxed_array_deserialize,
+    custom_compare_ext_default,
+    custom_fixed_length_default },
 };
 
 CAMLexport struct custom_operations caml_unboxed_int64_array_ops = {
@@ -481,14 +478,9 @@ CAMLprim value caml_make_unboxed_int32_vect(value len)
   mlsize_t num_elements = Long_val(len);
   /* [num_fields] does not include the custom operations field. */
   mlsize_t num_fields = (num_elements + 1) / 2;
-  struct custom_operations* ops;
-
-  if (num_elements % 2 == 0)
-    ops = &caml_unboxed_int32_even_array_ops;
-  else
-    ops = &caml_unboxed_int32_odd_array_ops;
 
-  return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0);
+  return caml_alloc_custom(&caml_unboxed_int32_array_ops[num_elements % 2],
+                           num_fields * sizeof(value), 0, 0);
 }
 
 CAMLprim value caml_make_unboxed_int64_vect(value len)

ocaml/runtime/caml/custom.h

@@ -36,6 +36,8 @@ struct custom_operations {
   int (*compare_ext)(value v1, value v2);
   const struct custom_fixed_length* fixed_length;
 };
+_Static_assert(sizeof(struct custom_operations) == CUSTOM_OPS_STRUCT_SIZE, 
+               "Unexpected CUSTOM_OPS_STRUCT_SIZE");
 
 #define custom_finalize_default NULL
 #define custom_compare_default NULL