Revert "Reorder fields in block header (#3042)"

This reverts commit 9eff722.

Author: ncik-roberts

backend/cmm_helpers.ml

@@ -74,12 +74,6 @@ type t =
 (* Mixed blocks, that need special header to specify the length of the scannable
    prefix. *)
 
-let addr_size_bits = Arch.size_addr * 8
-
-let header_wosize_bits = addr_size_bits - Config.reserved_header_bits - 10
-
-let header_max_size = (1 lsl header_wosize_bits) - 1
-
 module Mixed_block_support : sig
   val assert_mixed_block_support : unit -> unit
 
@@ -99,11 +93,16 @@ end = struct
      the all-0 pattern, and we must subtract 2 instead. *)
   let max_scannable_prefix = (1 lsl required_reserved_header_bits) - 2
 
+  let max_header =
+    (1 lsl (required_addr_size_bits - required_reserved_header_bits)) - 1
+    |> Nativeint.of_int
+
   let assert_mixed_block_support =
     lazy
       (if not Config.native_compiler
        then Misc.fatal_error "Mixed blocks are only supported in native code";
        let reserved_header_bits = Config.reserved_header_bits in
+       let addr_size_bits = Arch.size_addr * 8 in
        match
          ( reserved_header_bits = required_reserved_header_bits,
            addr_size_bits = required_addr_size_bits )
@@ -120,32 +119,32 @@ end = struct
 
   let assert_mixed_block_support () = Lazy.force assert_mixed_block_support
 
-  let scannable_prefix_position = 10
-
   let make_header header ~scannable_prefix =
     assert_mixed_block_support ();
     if scannable_prefix > max_scannable_prefix
     then
       Misc.fatal_errorf "Scannable prefix too big (%d > %d)" scannable_prefix
         max_scannable_prefix;
+    (* This means we crash the compiler if someone tries to write a mixed record
+       with too many fields, but you effectively can't: you'd need something
+       like 2^46 fields. *)
+    if header > max_header
+    then
+      Misc.fatal_errorf
+        "Header too big for the mixed block encoding to be added (%nd > %nd)"
+        header max_header;
     Nativeint.add
       (Nativeint.shift_left
          (Nativeint.of_int (scannable_prefix + 1))
-         scannable_prefix_position)
+         (required_addr_size_bits - required_reserved_header_bits))
       header
 end
 
 (* CR mshinwell: update to use NOT_MARKABLE terminology *)
 let block_header ?(block_kind = Regular_block) tag sz =
-  (* This means we crash the compiler if someone tries to write a record with
-     too many fields, but you effectively can't: you'd need something like 2^46
-     fields. *)
-  if sz > header_max_size
-  then Misc.fatal_errorf "Size too large to encode in header %d" sz;
   let hdr =
     Nativeint.add
-      (Nativeint.shift_left (Nativeint.of_int sz)
-         (10 + Config.reserved_header_bits))
+      (Nativeint.shift_left (Nativeint.of_int sz) 10)
       (Nativeint.of_int tag)
   in
   match block_kind with
@@ -949,6 +948,13 @@ let get_header ptr dbg =
       [Cop (Cadda, [ptr; Cconst_int (-size_int, dbg)], dbg)],
       dbg )
 
+let get_header_masked ptr dbg =
+  if Config.reserved_header_bits > 0
+  then
+    let header_mask = (1 lsl (64 - Config.reserved_header_bits)) - 1 in
+    Cop (Cand, [get_header ptr dbg; Cconst_int (header_mask, dbg)], dbg)
+  else get_header ptr dbg
+
 let tag_offset = if big_endian then -1 else -size_int
 
 let get_tag ptr dbg =
@@ -967,20 +973,17 @@ let get_tag ptr dbg =
         dbg )
 
 let get_size ptr dbg =
-  Cop
-    ( Clsr,
-      [get_header ptr dbg; Cconst_int (10 + Config.reserved_header_bits, dbg)],
-      dbg )
+  Cop (Clsr, [get_header_masked ptr dbg; Cconst_int (10, dbg)], dbg)
 
 (* Array indexing *)
 
 let log2_size_addr = Misc.log2 size_addr
 
 let log2_size_float = Misc.log2 size_float
 
-let wordsize_shift = 9 + Config.reserved_header_bits
+let wordsize_shift = 9
 
-let numfloat_shift = wordsize_shift + log2_size_float - log2_size_addr
+let numfloat_shift = 9 + log2_size_float - log2_size_addr
 
 let addr_array_length_shifted hdr dbg =
   Cop (Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg)
@@ -3272,7 +3275,7 @@ let raise_prim raise_kind arg dbg =
 let negint arg dbg = Cop (Csubi, [Cconst_int (2, dbg); arg], dbg)
 
 let addr_array_length arg dbg =
-  let hdr = get_header arg dbg in
+  let hdr = get_header_masked arg dbg in
   Cop (Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
 
 (* CR-soon gyorsh: effects and coeffects for primitives are set conservatively

ocaml/asmcomp/cmm_helpers.ml

@@ -735,7 +735,6 @@ let get_header ptr dbg =
     [Cop(Cadda, [ptr; Cconst_int(-size_int, dbg)], dbg)], dbg)
 
 let get_header_masked ptr dbg =
-  if true then failwith "this code has not been updated for runtime changes, but isn't used";
   if Config.reserved_header_bits > 0 then
     let header_mask = (1 lsl (64 - Config.reserved_header_bits)) - 1
     in Cop(Cand, [get_header ptr dbg; Cconst_int (header_mask, dbg)], dbg)

ocaml/asmcomp/cmm_helpers.mli

@@ -227,6 +227,9 @@ val set_field :
 (** Load a block's header *)
 val get_header : expression -> Debuginfo.t -> expression
 
+(** Same as [get_header], but also clear all reserved bits of the result *)
+val get_header_masked : expression -> Debuginfo.t -> expression
+
 (** Load a block's tag *)
 val get_tag : expression -> Debuginfo.t -> expression
 

ocaml/debugger/debugcom.ml

@@ -299,8 +299,8 @@ module Remote_value =
         flush !conn.io_out;
         let header = input_binary_int !conn.io_in in
         if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32
-        then header lsr (11 + Config.reserved_header_bits)
-        else header lsr (10 + Config.reserved_header_bits)
+        then header lsr 11
+        else header lsr 10
 
     let field v n =
       match v with

ocaml/debugger4/debugcom.ml

@@ -357,8 +357,8 @@ module Remote_value =
         flush !conn.io_out;
         let header = input_binary_int !conn.io_in in
         if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32
-        then header lsr (11 + Config.reserved_header_bits)
-        else header lsr (10 + Config.reserved_header_bits)
+        then header lsr 11
+        else header lsr 10
 
     let field v n =
       match v with

ocaml/runtime/alloc.c

@@ -31,10 +31,6 @@
 #include "caml/fiber.h"
 #include "caml/domain.h"
 
-/* When you update this macro, be sure to also update the exported value. */
-Assert_mixed_block_layout_v2;
-value caml_mixed_block_layout_version = 2;
-
 CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag,
                                            reserved_t reserved)
 {

ocaml/runtime/caml/mlvalues.h

@@ -101,10 +101,10 @@ bits  31    10 9     8 7   0
 
 For 64-bit architectures:
 
-     +--------+----------+-------+-----+
-     | wosize | reserved | color | tag |
-     +--------+----------+-------+-----+
-bits  63       R+10    10 9     8 7   0
+     +----------+--------+-------+-----+
+     | reserved | wosize | color | tag |
+     +----------+--------+-------+-----+
+bits  63    64-R 63-R  10 9     8 7   0
 
 where 0 <= R <= 31 is HEADER_RESERVED_BITS. R is always
 set to 8 for the flambda-backend compiler in order to support
@@ -123,34 +123,25 @@ mixed blocks. In the upstream compiler, R is set with the
 #define HEADER_COLOR_MASK (((1ull << HEADER_COLOR_BITS) - 1ull) \
                             << HEADER_COLOR_SHIFT)
 
-// HEADER_RESERVED_BITS is defined by configuration
-#define HEADER_RESERVED_SHIFT (HEADER_COLOR_SHIFT + HEADER_COLOR_BITS)
-
 #define HEADER_WOSIZE_BITS (HEADER_BITS - HEADER_TAG_BITS \
                             - HEADER_COLOR_BITS - HEADER_RESERVED_BITS)
-#define HEADER_WOSIZE_SHIFT (HEADER_RESERVED_BITS + HEADER_RESERVED_SHIFT)
+#define HEADER_WOSIZE_SHIFT (HEADER_COLOR_SHIFT  + HEADER_COLOR_BITS)
 #define HEADER_WOSIZE_MASK (((1ull << HEADER_WOSIZE_BITS) - 1ull) \
                              << HEADER_WOSIZE_SHIFT)
 
 #define Tag_hd(hd) ((tag_t) ((hd) & HEADER_TAG_MASK))
 #define Hd_with_tag(hd, tag) (((hd) &~ HEADER_TAG_MASK) | (tag))
-
-/* By construction, there's nothing above wosize in header, so we don't need to
-   mask, only shift. */
-#define Allocated_wosize_hd(hd) ((mlsize_t) ((hd) >> HEADER_WOSIZE_SHIFT))
+#define Allocated_wosize_hd(hd) ((mlsize_t) (((hd) & HEADER_WOSIZE_MASK) \
+                                     >> HEADER_WOSIZE_SHIFT))
 
 /* A "clean" header, without reserved or color bits. */
 #define Cleanhd_hd(hd) (((header_t)(hd)) & \
                         (HEADER_TAG_MASK | HEADER_WOSIZE_MASK))
 
 #if HEADER_RESERVED_BITS > 0
 
-#define HEADER_RESERVED_MASK  (((1ull << HEADER_RESERVED_BITS) - 1ull) \
-                             << HEADER_RESERVED_SHIFT)
-
-#define Reserved_hd(hd)   ((((header_t) (hd)) & HEADER_RESERVED_MASK) \
-                             >> HEADER_RESERVED_SHIFT)
-
+#define HEADER_RESERVED_SHIFT (HEADER_BITS - HEADER_RESERVED_BITS)
+#define Reserved_hd(hd)   (((header_t) (hd)) >> HEADER_RESERVED_SHIFT)
 #define Hd_reserved(res)  ((header_t)(res) << HEADER_RESERVED_SHIFT)
 
 #else /* HEADER_RESERVED_BITS is 0 */
@@ -592,14 +583,13 @@ CAMLextern value caml_set_oo_id(value obj);
 
    Users can write:
 
-   Assert_mixed_block_layout_v2;
+   Assert_mixed_block_layout_v1;
 
    (Hack: we define using _Static_assert rather than just an empty
    definition so that users can write a semicolon, which is treated
    better by C formatters.)
  */
-#define Assert_mixed_block_layout_v2 _Static_assert(1, "")
-CAMLextern value mixed_block_layout_version;
+#define Assert_mixed_block_layout_v1 _Static_assert(1, "")
 
 /* Header for out-of-heap blocks. */
 

ocaml/runtime/extern.c

@@ -627,17 +627,7 @@ Caml_inline void extern_header(struct caml_extern_state* s,
   if (tag < 16 && sz < 8) {
     writebyte(s, PREFIX_SMALL_BLOCK + tag + (sz << 4));
   } else {
-    /* This is the equivalent of [Make_header] before our changes to reorder
-       mixed-block related fields.
-
-       Is marshalling guaranteed to be stable? I'm uncertain if there's a rule
-       about this or a guarantee made by Ocaml. But, as a matter of practice,
-       one can't build the compiler without crossming marshal/unmarshal
-       boundaries where one end is from system ocamlc and one end is from the
-       built one. As such, it is in practice unsafe to use our new headers in
-       marshalling.
-    */
-    header_t hd = (sz << 10) + tag;
+    header_t hd = Make_header(sz, tag, NOT_MARKABLE);
 #ifdef ARCH_SIXTYFOUR
     if (sz > 0x3FFFFF && (s->extern_flags & COMPAT_32))
       extern_failwith(s, "output_value: array cannot be read back on "

ocaml/runtime/hash.c

@@ -180,12 +180,6 @@ CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s)
 /* Maximal number of Forward_tag links followed in one step */
 #define MAX_FORWARD_DEREFERENCE 1000
 
-/* A version of Cleanhd_hd that's compatible with what upstream does.
-   This allows us to avoid changing the output of polymorphic hash,
-   at a performance cost to users of polymorphic hash.
- */
-#define Stable_cleanhd_hd(hd) ((Wosize_hd(hd) << 10) | Tag_hd(hd))
-
 /* The generic hash function */
 
 /* Internally to Jane Street, we have renamed [caml_hash] to [caml_hash_exn]
@@ -273,7 +267,7 @@ CAMLprim value caml_hash_exn(value count, value limit, value seed, value obj)
         startenv = Start_env_closinfo(Closinfo_val(v));
         CAMLassert (startenv <= len);
         /* Mix in the tag and size, but do not count this towards [num] */
-        h = caml_hash_mix_uint32(h, Stable_cleanhd_hd(Hd_val(v)));
+        h = caml_hash_mix_uint32(h, Cleanhd_hd(Hd_val(v)));
         /* Mix the code pointers, closure info fields, and infix headers */
         for (i = 0; i < startenv; i++) {
           h = caml_hash_mix_intnat(h, Field(v, i));
@@ -297,7 +291,7 @@ CAMLprim value caml_hash_exn(value count, value limit, value seed, value obj)
 	  caml_invalid_argument("hash: mixed block value");
 	}
         /* Mix in the tag and size, but do not count this towards [num] */
-        h = caml_hash_mix_uint32(h, Stable_cleanhd_hd(Hd_val(v)));
+        h = caml_hash_mix_uint32(h, Cleanhd_hd(Hd_val(v)));
         /* Copy fields into queue, not exceeding the total size [sz] */
         for (i = 0, len = Wosize_val(v); i < len; i++) {
           if (wr >= sz) break;

ocaml/runtime/intern.c

@@ -591,15 +591,13 @@ static void intern_rec(struct caml_intern_state* s,
       case CODE_BLOCK32:
         header = (header_t) read32u(s);
         tag = Tag_hd(header);
-        /* See comment in extern.c extern_header() */
-        size = header >> 10;
+        size = Wosize_hd(header);
         goto read_block;
 #ifdef ARCH_SIXTYFOUR
       case CODE_BLOCK64:
         header = (header_t) read64u(s);
         tag = Tag_hd(header);
-        /* See comment in extern.c extern_header() */
-        size = header >> 10;
+        size = Wosize_hd(header);
         goto read_block;
 #endif
       case CODE_STRING8:

ocaml/runtime4/alloc.c

@@ -32,10 +32,6 @@
 #define Setup_for_gc
 #define Restore_after_gc
 
-/* When you update this macro, be sure to also update the exported value. */
-Assert_mixed_block_layout_v2;
-value caml_mixed_block_layout_version = 2;
-
 CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag,
                                            reserved_t reserved)
 {

ocaml/runtime4/caml/gc.h

@@ -41,7 +41,7 @@
 /* This depends on the layout of the header.  See [mlvalues.h]. */
 #define Make_header(wosize, tag, color)                                       \
       (/*CAMLassert ((wosize) <= Max_wosize),*/                               \
-       ((header_t) (((header_t) (wosize) << (10+PROFINFO_WIDTH))              \
+       ((header_t) (((header_t) (wosize) << 10)                               \
                     + (color)                                                 \
                     + (tag_t) (tag)))                                         \
       )

ocaml/runtime4/caml/mlvalues.h

@@ -110,18 +110,18 @@ bits  63    10 9     8 7   0
 
 For 64-bit architectures with mixed block support enabled:
   P = PROFINFO_WIDTH (as set by "configure", currently 8 bits)
-     +----- --+------------------------+-------------+
-     | wosize | scannable size         | color | tag |
-     +--------+------------------------+-------------+
-bits  63      (P+10)                 10 9     8 7   0
+     +----------------+----------------+-------------+
+     | scannable size | wosize         | color | tag |
+     +----------------+----------------+-------------+
+bits  63        (64-P) (63-P)        10 9     8 7   0
 
 Mixed block support uses the PROFINFO_WIDTH functionality
 originally built for Spacetime profiling, hence the odd name.
 */
 
 #define Tag_hd(hd) ((tag_t) ((hd) & 0xFF))
 
-#define Gen_profinfo_shift(width) (10)
+#define Gen_profinfo_shift(width) (64 - (width))
 #define Gen_profinfo_mask(width) ((1ull << (width)) - 1ull)
 #define Gen_profinfo_hd(width, hd) \
   (((mlsize_t) ((hd) >> (Gen_profinfo_shift(width)))) \
@@ -131,9 +131,8 @@ originally built for Spacetime profiling, hence the odd name.
 #define PROFINFO_SHIFT (Gen_profinfo_shift(PROFINFO_WIDTH))
 #define PROFINFO_MASK (Gen_profinfo_mask(PROFINFO_WIDTH))
 #define NO_PROFINFO 0
-
-#define HD_WOSIZE_SHIFT (PROFINFO_SHIFT + PROFINFO_WIDTH)
-#define Allocated_wosize_hd(hd) ((mlsize_t) ((hd) >> HD_WOSIZE_SHIFT))
+#define Hd_no_profinfo(hd) ((hd) & ~(PROFINFO_MASK << PROFINFO_SHIFT))
+#define Allocated_wosize_hd(hd) ((mlsize_t) ((Hd_no_profinfo(hd)) >> 10))
 #define Profinfo_hd(hd) (Gen_profinfo_hd(PROFINFO_WIDTH, hd))
 #else
 #define NO_PROFINFO 0
@@ -557,14 +556,13 @@ CAMLextern value caml_set_oo_id(value obj);
 
    Users can write:
 
-   Assert_mixed_block_layout_v2;
+   Assert_mixed_block_layout_v1;
 
    (Hack: we define using _Static_assert rather than just an empty
    definition so that users can write a semicolon, which is treated
    better by C formatters.)
  */
-#define Assert_mixed_block_layout_v2 _Static_assert(1, "")
-CAMLextern value mixed_block_layout_version; /* To help us in coredumps. */
+#define Assert_mixed_block_layout_v1 _Static_assert(1, "")
 
 /* Header for out-of-heap blocks. */