Skip to content

Commit 604ea6a

Browse files
committed
Revert "Reorder fields in block header (#3042)"
This reverts commit 9eff722.
1 parent 9ac3b0c commit 604ea6a

File tree

17 files changed

+65
-119
lines changed

17 files changed

+65
-119
lines changed

backend/cmm_helpers.ml

Lines changed: 26 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -74,12 +74,6 @@ type t =
7474
(* Mixed blocks, that need special header to specify the length of the scannable
7575
prefix. *)
7676

77-
let addr_size_bits = Arch.size_addr * 8
78-
79-
let header_wosize_bits = addr_size_bits - Config.reserved_header_bits - 10
80-
81-
let header_max_size = (1 lsl header_wosize_bits) - 1
82-
8377
module Mixed_block_support : sig
8478
val assert_mixed_block_support : unit -> unit
8579

@@ -99,11 +93,16 @@ end = struct
9993
the all-0 pattern, and we must subtract 2 instead. *)
10094
let max_scannable_prefix = (1 lsl required_reserved_header_bits) - 2
10195

96+
let max_header =
97+
(1 lsl (required_addr_size_bits - required_reserved_header_bits)) - 1
98+
|> Nativeint.of_int
99+
102100
let assert_mixed_block_support =
103101
lazy
104102
(if not Config.native_compiler
105103
then Misc.fatal_error "Mixed blocks are only supported in native code";
106104
let reserved_header_bits = Config.reserved_header_bits in
105+
let addr_size_bits = Arch.size_addr * 8 in
107106
match
108107
( reserved_header_bits = required_reserved_header_bits,
109108
addr_size_bits = required_addr_size_bits )
@@ -120,32 +119,32 @@ end = struct
120119

121120
let assert_mixed_block_support () = Lazy.force assert_mixed_block_support
122121

123-
let scannable_prefix_position = 10
124-
125122
let make_header header ~scannable_prefix =
126123
assert_mixed_block_support ();
127124
if scannable_prefix > max_scannable_prefix
128125
then
129126
Misc.fatal_errorf "Scannable prefix too big (%d > %d)" scannable_prefix
130127
max_scannable_prefix;
128+
(* This means we crash the compiler if someone tries to write a mixed record
129+
with too many fields, but you effectively can't: you'd need something
130+
like 2^46 fields. *)
131+
if header > max_header
132+
then
133+
Misc.fatal_errorf
134+
"Header too big for the mixed block encoding to be added (%nd > %nd)"
135+
header max_header;
131136
Nativeint.add
132137
(Nativeint.shift_left
133138
(Nativeint.of_int (scannable_prefix + 1))
134-
scannable_prefix_position)
139+
(required_addr_size_bits - required_reserved_header_bits))
135140
header
136141
end
137142

138143
(* CR mshinwell: update to use NOT_MARKABLE terminology *)
139144
let block_header ?(block_kind = Regular_block) tag sz =
140-
(* This means we crash the compiler if someone tries to write a record with
141-
too many fields, but you effectively can't: you'd need something like 2^46
142-
fields. *)
143-
if sz > header_max_size
144-
then Misc.fatal_errorf "Size too large to encode in header %d" sz;
145145
let hdr =
146146
Nativeint.add
147-
(Nativeint.shift_left (Nativeint.of_int sz)
148-
(10 + Config.reserved_header_bits))
147+
(Nativeint.shift_left (Nativeint.of_int sz) 10)
149148
(Nativeint.of_int tag)
150149
in
151150
match block_kind with
@@ -949,6 +948,13 @@ let get_header ptr dbg =
949948
[Cop (Cadda, [ptr; Cconst_int (-size_int, dbg)], dbg)],
950949
dbg )
951950

951+
let get_header_masked ptr dbg =
952+
if Config.reserved_header_bits > 0
953+
then
954+
let header_mask = (1 lsl (64 - Config.reserved_header_bits)) - 1 in
955+
Cop (Cand, [get_header ptr dbg; Cconst_int (header_mask, dbg)], dbg)
956+
else get_header ptr dbg
957+
952958
let tag_offset = if big_endian then -1 else -size_int
953959

954960
let get_tag ptr dbg =
@@ -967,20 +973,17 @@ let get_tag ptr dbg =
967973
dbg )
968974

969975
let get_size ptr dbg =
970-
Cop
971-
( Clsr,
972-
[get_header ptr dbg; Cconst_int (10 + Config.reserved_header_bits, dbg)],
973-
dbg )
976+
Cop (Clsr, [get_header_masked ptr dbg; Cconst_int (10, dbg)], dbg)
974977

975978
(* Array indexing *)
976979

977980
let log2_size_addr = Misc.log2 size_addr
978981

979982
let log2_size_float = Misc.log2 size_float
980983

981-
let wordsize_shift = 9 + Config.reserved_header_bits
984+
let wordsize_shift = 9
982985

983-
let numfloat_shift = wordsize_shift + log2_size_float - log2_size_addr
986+
let numfloat_shift = 9 + log2_size_float - log2_size_addr
984987

985988
let addr_array_length_shifted hdr dbg =
986989
Cop (Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg)
@@ -3272,7 +3275,7 @@ let raise_prim raise_kind arg dbg =
32723275
let negint arg dbg = Cop (Csubi, [Cconst_int (2, dbg); arg], dbg)
32733276

32743277
let addr_array_length arg dbg =
3275-
let hdr = get_header arg dbg in
3278+
let hdr = get_header_masked arg dbg in
32763279
Cop (Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
32773280

32783281
(* CR-soon gyorsh: effects and coeffects for primitives are set conservatively

ocaml/asmcomp/cmm_helpers.ml

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -735,7 +735,6 @@ let get_header ptr dbg =
735735
[Cop(Cadda, [ptr; Cconst_int(-size_int, dbg)], dbg)], dbg)
736736

737737
let get_header_masked ptr dbg =
738-
if true then failwith "this code has not been updated for runtime changes, but isn't used";
739738
if Config.reserved_header_bits > 0 then
740739
let header_mask = (1 lsl (64 - Config.reserved_header_bits)) - 1
741740
in Cop(Cand, [get_header ptr dbg; Cconst_int (header_mask, dbg)], dbg)

ocaml/asmcomp/cmm_helpers.mli

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -227,6 +227,9 @@ val set_field :
227227
(** Load a block's header *)
228228
val get_header : expression -> Debuginfo.t -> expression
229229

230+
(** Same as [get_header], but also clear all reserved bits of the result *)
231+
val get_header_masked : expression -> Debuginfo.t -> expression
232+
230233
(** Load a block's tag *)
231234
val get_tag : expression -> Debuginfo.t -> expression
232235

ocaml/debugger/debugcom.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -299,8 +299,8 @@ module Remote_value =
299299
flush !conn.io_out;
300300
let header = input_binary_int !conn.io_in in
301301
if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32
302-
then header lsr (11 + Config.reserved_header_bits)
303-
else header lsr (10 + Config.reserved_header_bits)
302+
then header lsr 11
303+
else header lsr 10
304304

305305
let field v n =
306306
match v with

ocaml/debugger4/debugcom.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -357,8 +357,8 @@ module Remote_value =
357357
flush !conn.io_out;
358358
let header = input_binary_int !conn.io_in in
359359
if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32
360-
then header lsr (11 + Config.reserved_header_bits)
361-
else header lsr (10 + Config.reserved_header_bits)
360+
then header lsr 11
361+
else header lsr 10
362362

363363
let field v n =
364364
match v with

ocaml/runtime/alloc.c

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -31,10 +31,6 @@
3131
#include "caml/fiber.h"
3232
#include "caml/domain.h"
3333

34-
/* When you update this macro, be sure to also update the exported value. */
35-
Assert_mixed_block_layout_v2;
36-
value caml_mixed_block_layout_version = 2;
37-
3834
CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag,
3935
reserved_t reserved)
4036
{

ocaml/runtime/caml/mlvalues.h

Lines changed: 11 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -101,10 +101,10 @@ bits 31 10 9 8 7 0
101101
102102
For 64-bit architectures:
103103
104-
+--------+----------+-------+-----+
105-
| wosize | reserved | color | tag |
106-
+--------+----------+-------+-----+
107-
bits 63 R+10 10 9 8 7 0
104+
+----------+--------+-------+-----+
105+
| reserved | wosize | color | tag |
106+
+----------+--------+-------+-----+
107+
bits 63 64-R 63-R 10 9 8 7 0
108108
109109
where 0 <= R <= 31 is HEADER_RESERVED_BITS. R is always
110110
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
123123
#define HEADER_COLOR_MASK (((1ull << HEADER_COLOR_BITS) - 1ull) \
124124
<< HEADER_COLOR_SHIFT)
125125

126-
// HEADER_RESERVED_BITS is defined by configuration
127-
#define HEADER_RESERVED_SHIFT (HEADER_COLOR_SHIFT + HEADER_COLOR_BITS)
128-
129126
#define HEADER_WOSIZE_BITS (HEADER_BITS - HEADER_TAG_BITS \
130127
- HEADER_COLOR_BITS - HEADER_RESERVED_BITS)
131-
#define HEADER_WOSIZE_SHIFT (HEADER_RESERVED_BITS + HEADER_RESERVED_SHIFT)
128+
#define HEADER_WOSIZE_SHIFT (HEADER_COLOR_SHIFT + HEADER_COLOR_BITS)
132129
#define HEADER_WOSIZE_MASK (((1ull << HEADER_WOSIZE_BITS) - 1ull) \
133130
<< HEADER_WOSIZE_SHIFT)
134131

135132
#define Tag_hd(hd) ((tag_t) ((hd) & HEADER_TAG_MASK))
136133
#define Hd_with_tag(hd, tag) (((hd) &~ HEADER_TAG_MASK) | (tag))
137-
138-
/* By construction, there's nothing above wosize in header, so we don't need to
139-
mask, only shift. */
140-
#define Allocated_wosize_hd(hd) ((mlsize_t) ((hd) >> HEADER_WOSIZE_SHIFT))
134+
#define Allocated_wosize_hd(hd) ((mlsize_t) (((hd) & HEADER_WOSIZE_MASK) \
135+
>> HEADER_WOSIZE_SHIFT))
141136

142137
/* A "clean" header, without reserved or color bits. */
143138
#define Cleanhd_hd(hd) (((header_t)(hd)) & \
144139
(HEADER_TAG_MASK | HEADER_WOSIZE_MASK))
145140

146141
#if HEADER_RESERVED_BITS > 0
147142

148-
#define HEADER_RESERVED_MASK (((1ull << HEADER_RESERVED_BITS) - 1ull) \
149-
<< HEADER_RESERVED_SHIFT)
150-
151-
#define Reserved_hd(hd) ((((header_t) (hd)) & HEADER_RESERVED_MASK) \
152-
>> HEADER_RESERVED_SHIFT)
153-
143+
#define HEADER_RESERVED_SHIFT (HEADER_BITS - HEADER_RESERVED_BITS)
144+
#define Reserved_hd(hd) (((header_t) (hd)) >> HEADER_RESERVED_SHIFT)
154145
#define Hd_reserved(res) ((header_t)(res) << HEADER_RESERVED_SHIFT)
155146

156147
#else /* HEADER_RESERVED_BITS is 0 */
@@ -592,14 +583,13 @@ CAMLextern value caml_set_oo_id(value obj);
592583
593584
Users can write:
594585
595-
Assert_mixed_block_layout_v2;
586+
Assert_mixed_block_layout_v1;
596587
597588
(Hack: we define using _Static_assert rather than just an empty
598589
definition so that users can write a semicolon, which is treated
599590
better by C formatters.)
600591
*/
601-
#define Assert_mixed_block_layout_v2 _Static_assert(1, "")
602-
CAMLextern value mixed_block_layout_version;
592+
#define Assert_mixed_block_layout_v1 _Static_assert(1, "")
603593

604594
/* Header for out-of-heap blocks. */
605595

ocaml/runtime/extern.c

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

ocaml/runtime/hash.c

Lines changed: 2 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -180,12 +180,6 @@ CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s)
180180
/* Maximal number of Forward_tag links followed in one step */
181181
#define MAX_FORWARD_DEREFERENCE 1000
182182

183-
/* A version of Cleanhd_hd that's compatible with what upstream does.
184-
This allows us to avoid changing the output of polymorphic hash,
185-
at a performance cost to users of polymorphic hash.
186-
*/
187-
#define Stable_cleanhd_hd(hd) ((Wosize_hd(hd) << 10) | Tag_hd(hd))
188-
189183
/* The generic hash function */
190184

191185
/* 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)
273267
startenv = Start_env_closinfo(Closinfo_val(v));
274268
CAMLassert (startenv <= len);
275269
/* Mix in the tag and size, but do not count this towards [num] */
276-
h = caml_hash_mix_uint32(h, Stable_cleanhd_hd(Hd_val(v)));
270+
h = caml_hash_mix_uint32(h, Cleanhd_hd(Hd_val(v)));
277271
/* Mix the code pointers, closure info fields, and infix headers */
278272
for (i = 0; i < startenv; i++) {
279273
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)
297291
caml_invalid_argument("hash: mixed block value");
298292
}
299293
/* Mix in the tag and size, but do not count this towards [num] */
300-
h = caml_hash_mix_uint32(h, Stable_cleanhd_hd(Hd_val(v)));
294+
h = caml_hash_mix_uint32(h, Cleanhd_hd(Hd_val(v)));
301295
/* Copy fields into queue, not exceeding the total size [sz] */
302296
for (i = 0, len = Wosize_val(v); i < len; i++) {
303297
if (wr >= sz) break;

ocaml/runtime/intern.c

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -591,15 +591,13 @@ static void intern_rec(struct caml_intern_state* s,
591591
case CODE_BLOCK32:
592592
header = (header_t) read32u(s);
593593
tag = Tag_hd(header);
594-
/* See comment in extern.c extern_header() */
595-
size = header >> 10;
594+
size = Wosize_hd(header);
596595
goto read_block;
597596
#ifdef ARCH_SIXTYFOUR
598597
case CODE_BLOCK64:
599598
header = (header_t) read64u(s);
600599
tag = Tag_hd(header);
601-
/* See comment in extern.c extern_header() */
602-
size = header >> 10;
600+
size = Wosize_hd(header);
603601
goto read_block;
604602
#endif
605603
case CODE_STRING8:

ocaml/runtime4/alloc.c

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -32,10 +32,6 @@
3232
#define Setup_for_gc
3333
#define Restore_after_gc
3434

35-
/* When you update this macro, be sure to also update the exported value. */
36-
Assert_mixed_block_layout_v2;
37-
value caml_mixed_block_layout_version = 2;
38-
3935
CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag,
4036
reserved_t reserved)
4137
{

ocaml/runtime4/caml/gc.h

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,7 @@
4141
/* This depends on the layout of the header. See [mlvalues.h]. */
4242
#define Make_header(wosize, tag, color) \
4343
(/*CAMLassert ((wosize) <= Max_wosize),*/ \
44-
((header_t) (((header_t) (wosize) << (10+PROFINFO_WIDTH)) \
44+
((header_t) (((header_t) (wosize) << 10) \
4545
+ (color) \
4646
+ (tag_t) (tag))) \
4747
)

ocaml/runtime4/caml/mlvalues.h

Lines changed: 9 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -110,18 +110,18 @@ bits 63 10 9 8 7 0
110110
111111
For 64-bit architectures with mixed block support enabled:
112112
P = PROFINFO_WIDTH (as set by "configure", currently 8 bits)
113-
+----- --+------------------------+-------------+
114-
| wosize | scannable size | color | tag |
115-
+--------+------------------------+-------------+
116-
bits 63 (P+10) 10 9 8 7 0
113+
+----------------+----------------+-------------+
114+
| scannable size | wosize | color | tag |
115+
+----------------+----------------+-------------+
116+
bits 63 (64-P) (63-P) 10 9 8 7 0
117117
118118
Mixed block support uses the PROFINFO_WIDTH functionality
119119
originally built for Spacetime profiling, hence the odd name.
120120
*/
121121

122122
#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF))
123123

124-
#define Gen_profinfo_shift(width) (10)
124+
#define Gen_profinfo_shift(width) (64 - (width))
125125
#define Gen_profinfo_mask(width) ((1ull << (width)) - 1ull)
126126
#define Gen_profinfo_hd(width, hd) \
127127
(((mlsize_t) ((hd) >> (Gen_profinfo_shift(width)))) \
@@ -131,9 +131,8 @@ originally built for Spacetime profiling, hence the odd name.
131131
#define PROFINFO_SHIFT (Gen_profinfo_shift(PROFINFO_WIDTH))
132132
#define PROFINFO_MASK (Gen_profinfo_mask(PROFINFO_WIDTH))
133133
#define NO_PROFINFO 0
134-
135-
#define HD_WOSIZE_SHIFT (PROFINFO_SHIFT + PROFINFO_WIDTH)
136-
#define Allocated_wosize_hd(hd) ((mlsize_t) ((hd) >> HD_WOSIZE_SHIFT))
134+
#define Hd_no_profinfo(hd) ((hd) & ~(PROFINFO_MASK << PROFINFO_SHIFT))
135+
#define Allocated_wosize_hd(hd) ((mlsize_t) ((Hd_no_profinfo(hd)) >> 10))
137136
#define Profinfo_hd(hd) (Gen_profinfo_hd(PROFINFO_WIDTH, hd))
138137
#else
139138
#define NO_PROFINFO 0
@@ -557,14 +556,13 @@ CAMLextern value caml_set_oo_id(value obj);
557556
558557
Users can write:
559558
560-
Assert_mixed_block_layout_v2;
559+
Assert_mixed_block_layout_v1;
561560
562561
(Hack: we define using _Static_assert rather than just an empty
563562
definition so that users can write a semicolon, which is treated
564563
better by C formatters.)
565564
*/
566-
#define Assert_mixed_block_layout_v2 _Static_assert(1, "")
567-
CAMLextern value mixed_block_layout_version; /* To help us in coredumps. */
565+
#define Assert_mixed_block_layout_v1 _Static_assert(1, "")
568566

569567
/* Header for out-of-heap blocks. */
570568

0 commit comments

Comments
 (0)