From ecbe37a1719b70aea84edbb58e32c36a603a7421 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Tue, 23 Apr 2024 12:12:51 -0400 Subject: [PATCH] flambda-backend: Implement mixed blocks in runtime 4 (#2422) * First attempt, buggy * 'Fix bug' (rectify my understanding by imposing my will on NO_PROFINFO * Reenable and run tests * Add unimplemented function for large-enough mixed blocks * Fix bug (missed 'signpost', in the idiom of the PR description) * Fix upstream build * review: Bosize_val * Fix accounting: don't claim that you scanned the flat suffix * Fix never-ending comment --- runtime4/alloc.c | 80 ++++++++++++++++--- runtime4/array.c | 12 ++- runtime4/caml/alloc.h | 5 ++ runtime4/caml/memory.h | 8 ++ runtime4/caml/mlvalues.h | 39 +++++++++ runtime4/compact.c | 3 +- runtime4/compare.c | 5 ++ runtime4/extern.c | 18 +++-- runtime4/gc_ctrl.c | 2 +- runtime4/hash.c | 9 ++- runtime4/major_gc.c | 15 ++-- runtime4/memory.c | 8 ++ runtime4/minor_gc.c | 25 +++++- runtime4/misc.c | 2 + runtime4/obj.c | 17 +++- runtime4/roots_nat.c | 44 +++++----- runtime4/weak.c | 27 ++++--- .../generate_mixed_blocks_code.ml | 12 ++- .../tests/mixed-blocks/generated_byte_test.ml | 1 - .../mixed-blocks/generated_native_test.ml | 2 +- testsuite/tests/mixed-blocks/hash.ml | 4 +- .../mixed-blocks/recursive_mixed_blocks.ml | 2 +- .../tests/mixed-blocks/test_mixed_blocks.ml | 1 - testsuite/tests/mixed-blocks/test_printing.ml | 1 - .../tests/mixed-blocks/test_runtime_4.ml | 38 --------- .../typing_recursive_mixed_blocks.ml | 1 - .../unboxed_floats_alpha.ml | 1 - .../tests/typing-layouts/mixed_records.ml | 1 - .../typing-layouts/mixed_records_alpha.ml | 1 - typing/typedecl.ml | 3 +- 30 files changed, 273 insertions(+), 114 deletions(-) delete mode 100644 testsuite/tests/mixed-blocks/test_runtime_4.ml diff --git a/runtime4/alloc.c b/runtime4/alloc.c index bd8d0e4e87d..613419cfb36 100644 --- a/runtime4/alloc.c +++ b/runtime4/alloc.c @@ -32,43 +32,70 @@ #define Setup_for_gc #define Restore_after_gc -CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag, + reserved_t reserved) { + value result; mlsize_t i; + // Optimization: for mixed blocks, don't fill in non-scannable fields + mlsize_t scannable_wosize = + Is_mixed_block_reserved(reserved) + ? Mixed_block_scannable_wosize_reserved(reserved) + : wosize; + CAMLassert (tag < 256); CAMLassert (tag != Infix_tag); if (wosize <= Max_young_wosize){ if (wosize == 0){ result = Atom (tag); }else{ - Alloc_small (result, wosize, tag); + Alloc_small_with_reserved (result, wosize, tag, reserved); if (tag < No_scan_tag){ - for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; + for (i = 0; i < scannable_wosize; i++) Field (result, i) = Val_unit; } } }else{ - result = caml_alloc_shr (wosize, tag); + result = caml_alloc_shr_reserved (wosize, tag, reserved); if (tag < No_scan_tag){ - for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; + for (i = 0; i < scannable_wosize; i++) Field (result, i) = Val_unit; } result = caml_check_urgent_gc (result); } return result; } -CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) { + return caml_alloc_with_reserved (wosize, tag, 0); +} + +CAMLexport value caml_alloc_mixed (mlsize_t wosize, tag_t tag, + mlsize_t scannable_prefix) { + reserved_t reserved = + Reserved_mixed_block_scannable_wosize(scannable_prefix); + return caml_alloc_with_reserved (wosize, tag, reserved); +} + +CAMLexport value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t tag, + reserved_t reserved) { value result; CAMLassert (wosize > 0); CAMLassert (wosize <= Max_young_wosize); CAMLassert (tag < 256); - Alloc_small (result, wosize, tag); + CAMLassert (tag != Infix_tag); + Alloc_small_with_reserved (result, wosize, tag, reserved); return result; } +CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_small_with_reserved(wosize, tag, 0); +} + + /* [n] is a number of words (fields) */ CAMLexport value caml_alloc_tuple(mlsize_t n) { @@ -220,6 +247,28 @@ CAMLprim value caml_alloc_dummy_float (value size) return caml_alloc (wosize, 0); } +/* [size] is a [value] representing the number of fields. + [scannable_size] is a [value] representing the length of the prefix of + fields that contains pointer values. +*/ +CAMLprim value caml_alloc_dummy_mixed (value size, value scannable_size) +{ + mlsize_t wosize = Long_val(size); + mlsize_t scannable_wosize = Long_val(scannable_size); +#ifdef NATIVECODE + /* The below code runs for bytecode and native code, and critically assumes + that a double record field can be stored in one word. That's true both for + 32-bit and 64-bit bytecode (as a double record field in a mixed record is + always boxed), and for 64-bit native code (as the double record field is + stored flat, taking up 1 word). + */ + CAML_STATIC_ASSERT(Double_wosize == 1); +#endif + reserved_t reserved = + Reserved_mixed_block_scannable_wosize(scannable_wosize); + return caml_alloc_with_reserved (wosize, 0, reserved); +} + CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset) { mlsize_t wosize = Long_val(vsize), offset = Long_val(voffset); @@ -270,14 +319,25 @@ CAMLprim value caml_update_dummy(value dummy, value newval) } else { CAMLassert (tag < No_scan_tag); CAMLassert (Tag_val(dummy) != Infix_tag); + CAMLassert (Reserved_val(dummy) == Reserved_val(newval)); Tag_val(dummy) = tag; size = Wosize_val(newval); CAMLassert (size == Wosize_val(dummy)); + mlsize_t scannable_size = Scannable_wosize_val(newval); + CAMLassert (scannable_size == Scannable_wosize_val(dummy)); /* See comment above why this is safe even if [tag == Closure_tag] - and some of the "values" being copied are actually code pointers. */ - for (i = 0; i < size; i++){ + and some of the "values" being copied are actually code pointers. + + This reasoning does not apply to arbitrary flat fields, which might have + the same shape as pointers into the minor heap, so we need to handle the + non-scannable suffix of mixed blocks specially. + */ + for (i = 0; i < scannable_size; i++){ caml_modify (&Field(dummy, i), Field(newval, i)); } + for (i = scannable_size; i < size; i++) { + Field(dummy, i) = Field(newval, i); + } } return Val_unit; } @@ -293,4 +353,4 @@ CAMLexport value caml_alloc_some(value v) CAMLprim value caml_atomic_make_contended(value v) { caml_fatal_error("Atomic.make_contended is not supported by runtime4"); -} \ No newline at end of file +} diff --git a/runtime4/array.c b/runtime4/array.c index ce442982d0f..0fd028887f2 100644 --- a/runtime4/array.c +++ b/runtime4/array.c @@ -133,7 +133,11 @@ CAMLprim value caml_floatarray_get(value array, value index) double d; value res; - CAMLassert (Tag_val(array) == Double_array_tag); + // [caml_floatarray_get] may be called on a floatarray + // or a mixed block. + CAMLassert ( Tag_val(array) == Double_array_tag + || index > Scannable_wosize_val(array) ); + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) caml_array_bound_error(); d = Double_flat_field(array, idx); @@ -153,7 +157,11 @@ CAMLprim value caml_floatarray_get_local(value array, value index) double d; value res; - CAMLassert (Tag_val(array) == Double_array_tag); + // [caml_floatarray_get] may be called on a floatarray + // or a mixed block. + CAMLassert ( Tag_val(array) == Double_array_tag + || index > Scannable_wosize_val(array) ); + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) caml_array_bound_error(); d = Double_flat_field(array, idx); diff --git a/runtime4/caml/alloc.h b/runtime4/caml/alloc.h index 2d86cb6dfcc..f489fc0cd63 100644 --- a/runtime4/caml/alloc.h +++ b/runtime4/caml/alloc.h @@ -30,8 +30,13 @@ extern "C" { /* It is guaranteed that these allocation functions will not trigger any OCaml callback such as finalizers or signal handlers. */ +CAMLextern value caml_alloc_with_reserved (mlsize_t, tag_t, reserved_t); CAMLextern value caml_alloc (mlsize_t wosize, tag_t); +CAMLextern value caml_alloc_mixed (mlsize_t wosize, tag_t, + mlsize_t scannable_wosize); CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t); +CAMLextern value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t, + reserved_t); CAMLextern value caml_alloc_tuple (mlsize_t wosize); CAMLextern value caml_alloc_float_array (mlsize_t len); CAMLextern value caml_alloc_string (mlsize_t len); /* len in bytes (chars) */ diff --git a/runtime4/caml/memory.h b/runtime4/caml/memory.h index faa11213561..e5204f92f96 100644 --- a/runtime4/caml/memory.h +++ b/runtime4/caml/memory.h @@ -41,6 +41,11 @@ CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); Equivalent to caml_alloc_shr unless WITH_PROFINFO is true */ CAMLextern value caml_alloc_shr_with_profinfo (mlsize_t, tag_t, intnat); +/* The same as [caml_alloc_shr_with_profinfo], but named to match the runtime5 + naming convention of reserved bits. + */ +CAMLextern value caml_alloc_shr_reserved (mlsize_t, tag_t, reserved_t); + /* Variant of [caml_alloc_shr] where no memprof sampling is performed. */ CAMLextern value caml_alloc_shr_no_track_noexc (mlsize_t, tag_t); @@ -240,6 +245,9 @@ extern void caml_alloc_small_dispatch (intnat wosize, int flags, #define Alloc_small_with_profinfo(result, wosize, tag, profinfo) \ Alloc_small_aux(result, wosize, tag, profinfo, CAML_DO_TRACK) +#define Alloc_small_with_reserved(result, wosize, tag, reserved) \ + Alloc_small_with_profinfo(result, wosize, tag, reserved) + #define Alloc_small(result, wosize, tag) \ Alloc_small_with_profinfo(result, wosize, tag, (uintnat) 0) #define Alloc_small_no_track(result, wosize, tag) \ diff --git a/runtime4/caml/mlvalues.h b/runtime4/caml/mlvalues.h index a59686cbe1c..0409de27a5b 100644 --- a/runtime4/caml/mlvalues.h +++ b/runtime4/caml/mlvalues.h @@ -60,6 +60,11 @@ extern "C" { typedef intnat value; typedef uintnat header_t; typedef uintnat mlsize_t; +typedef header_t reserved_t; /* Same role as reserved_t in runtime 5 (reserved + header bits). The mechanism for reserving bits + in runtime 4 is different than runtime 5: it's + the WITH_PROFINFO and PROFINFO_WIDTH macros. + */ typedef unsigned int tag_t; /* Actually, an unsigned char */ typedef uintnat color_t; typedef uintnat mark_t; @@ -135,6 +140,40 @@ originally built for Spacetime profiling, hence the odd name. #define Profinfo_hd(hd) NO_PROFINFO #endif /* WITH_PROFINFO */ +/* Header bits reserved for mixed blocks */ + +#define Reserved_hd(hd) ((reserved_t)(Profinfo_hd(hd))) +#define Reserved_val(val) ((reserved_t)(Profinfo_val(val))) + +#define Scannable_wosize_val(val) (Scannable_wosize_hd (Hd_val (val))) + +#define Is_mixed_block_reserved(res) (((reserved_t)(res)) > 0) +#define Mixed_block_scannable_wosize_reserved(res) (((reserved_t)(res)) - 1) +#define Reserved_mixed_block_scannable_wosize(sz) (((mlsize_t)(sz)) + 1) + +/* The scannable size of a block is how many fields are values as opposed + to flat floats/ints/etc. This is different than the (normal) size of a + block for mixed blocks. + + The runtime has several functions that traverse over the structure of + an OCaml value. (e.g. polymorphic comparison, GC marking/sweeping) + All of these traversals must be written to have one of the following + properties: + - it's known that the input can never be a mixed block, + - it raises an exception on mixed blocks, or + - it uses the scannable size (not the normal size) to figure out which + fields to recursively descend into. + + Otherwise, the traversal could attempt to recursively descend into + a flat field, which could segfault (or worse). +*/ +Caml_inline mlsize_t Scannable_wosize_hd(header_t hd) { + reserved_t res = Reserved_hd(hd); + return + Is_mixed_block_reserved(res) + ? Mixed_block_scannable_wosize_reserved(res) + : Wosize_hd(hd); +} #define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ #define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ diff --git a/runtime4/compact.c b/runtime4/compact.c index a181be0ee45..fc029c8fa6c 100644 --- a/runtime4/compact.c +++ b/runtime4/compact.c @@ -178,6 +178,7 @@ static void do_compaction (intnat new_allocation_policy) while (Is_gray_hd (q)) q = * dptr (q); wosz = Wosize_hd (q); + mlsize_t scannable_wosz = Scannable_wosize_hd (q); if (Is_white_hd (q)){ t = Tag_hd (q); CAMLassert (t != Infix_tag); @@ -188,7 +189,7 @@ static void do_compaction (intnat new_allocation_policy) }else{ first_field = 0; } - for (i = first_field; i < wosz; i++){ + for (i = first_field; i < scannable_wosz; i++){ invert_pointer_at ((word *) &Field (v,i)); } } diff --git a/runtime4/compare.c b/runtime4/compare.c index 4a0eb6eac0a..d86a53f9d95 100644 --- a/runtime4/compare.c +++ b/runtime4/compare.c @@ -194,6 +194,11 @@ static intnat do_compare_val(struct compare_stack* stk, if (t1 != t2) return (intnat)t1 - (intnat)t2; } + if ( Is_mixed_block_reserved(Reserved_val(v1)) + || Is_mixed_block_reserved(Reserved_val(v2))) { + compare_free_stack(stk); + caml_invalid_argument("compare: mixed block value"); + } switch(t1) { case Forward_tag: { v1 = Forward_val (v1); diff --git a/runtime4/extern.c b/runtime4/extern.c index 3b5fd37afcd..793282663b2 100644 --- a/runtime4/extern.c +++ b/runtime4/extern.c @@ -730,6 +730,11 @@ static void extern_rec(value v) header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); + reserved_t reserved = Reserved_hd(hd); + if (Is_mixed_block_reserved(reserved)) { + extern_invalid_argument("output_value: mixed block"); + break; + } if (tag == Forward_tag) { value f = Forward_val (v); @@ -1274,16 +1279,19 @@ intnat reachable_words_once(value root, intnat identifier, value sizes_by_root_i } } if (tag < No_scan_tag) { - /* i is the position of the first field to traverse recursively */ + /* i is the position of the first field to traverse recursively, + and j is the position of the last such field. + */ uintnat i = tag == Closure_tag ? Start_env_closinfo(Closinfo_val(v)) : 0; - if (i < sz) { - if (i < sz - 1) { - /* Remember that we need to count fields i + 1 ... sz - 1 */ + uintnat j = Scannable_wosize_hd(hd); + if (i < j) { + if (i < j - 1) { + /* Remember that we need to count fields i + 1 ... j - 1 */ sp++; if (sp >= extern_stack_limit) sp = extern_resize_stack(sp); sp->v = &Field(v, i + 1); - sp->count = sz - i - 1; + sp->count = j - i - 1; } /* Continue with field i */ v = Field(v, i); diff --git a/runtime4/gc_ctrl.c b/runtime4/gc_ctrl.c index 2536612736e..8ec6174aa5a 100644 --- a/runtime4/gc_ctrl.c +++ b/runtime4/gc_ctrl.c @@ -116,7 +116,7 @@ static void check_block (header_t *hp) /* For closures, skip to the start of the scannable environment */ if (tag == Closure_tag) start = Start_env_closinfo(Closinfo_val(v)); else start = 0; - for (i = start; i < Wosize_hp (hp); i++){ + for (i = start; i < Scannable_wosize_hd (Hd_hp (hp)); i++){ f = Field (v, i); if (Is_block (f) && Is_in_heap (f)){ check_head (f); diff --git a/runtime4/hash.c b/runtime4/hash.c index da111db629e..39c0e16c6e9 100644 --- a/runtime4/hash.c +++ b/runtime4/hash.c @@ -286,10 +286,17 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) /* Mix in the tag and size, but do not count this towards [num] */ h = caml_hash_mix_uint32(h, Whitehd_hd(Hd_val(v))); /* Copy fields into queue, not exceeding the total size [sz] */ - for (i = 0, len = Wosize_val(v); i < len; i++) { + for (i = 0, len = Scannable_wosize_val(v); i < len; i++) { if (wr >= sz) break; queue[wr++] = Field(v, i); } + + /* We don't attempt to hash the flat suffix of a mixed block. + This is consistent with abstract blocks which, like mixed + blocks, cause polymorphic comparison to raise and don't + attempt to hash the non-scannable portion. + */ + break; } } diff --git a/runtime4/major_gc.c b/runtime4/major_gc.c index a0be700696e..030f9184077 100644 --- a/runtime4/major_gc.c +++ b/runtime4/major_gc.c @@ -214,7 +214,7 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block, uintnat offset, intnat* work) { value v; - int i, block_wsz = Wosize_val(block), end; + int i, block_scannable_wsz, end; mark_entry* me; CAMLassert(Is_block(block) && Is_in_heap (block) @@ -222,6 +222,8 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block, CAMLassert(Tag_val(block) != Infix_tag); CAMLassert(Tag_val(block) < No_scan_tag); + block_scannable_wsz = Scannable_wosize_val(block); + #if defined(NO_NAKED_POINTERS) || defined(NAKED_POINTERS_CHECKER) if (Tag_val(block) == Closure_tag) { /* Skip the code pointers and integers at beginning of closure; @@ -238,7 +240,7 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block, } #endif - end = (block_wsz < 8 ? block_wsz : 8); + end = (block_scannable_wsz < 8 ? block_scannable_wsz : 8); /* Optimisation to avoid pushing small, unmarkable objects such as [Some 42] * into the mark stack. */ @@ -250,11 +252,11 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block, break; } - if (i == block_wsz) { + if (i == block_scannable_wsz) { /* nothing left to mark */ if( work != NULL ) { /* we should take credit for it though */ - *work -= Whsize_wosize(block_wsz - offset); + *work -= Whsize_wosize(block_scannable_wsz - offset); } return; } @@ -273,7 +275,7 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block, me = &stk->stack[stk->count++]; me->start = Op_val(block) + offset; - me->end = Op_val(block) + Wosize_val(block); + me->end = Op_val(block) + block_scannable_wsz; } #if defined(NAKED_POINTERS_CHECKER) && defined(NATIVE_CODE) @@ -670,7 +672,8 @@ Caml_noinline static intnat do_some_marking continue; } scan = Op_val(block); - obj_end = scan + Wosize_hd(hd); + obj_end = scan + Scannable_wosize_hd(hd); + work -= Wosize_hd(hd) - Scannable_wosize_hd(hd); if (Tag_hd (hd) == Closure_tag) { uintnat env_offset = Start_env_closinfo(Closinfo_val(block)); diff --git a/runtime4/memory.c b/runtime4/memory.c index 88adaba5b3c..c57fb6dd43a 100644 --- a/runtime4/memory.c +++ b/runtime4/memory.c @@ -528,6 +528,8 @@ Caml_inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, int track, #ifdef DEBUG { uintnat i; + /* We don't check the reserved bits here because this is OK even for mixed + blocks. */ for (i = 0; i < wosize; i++){ Field (Val_hp (hp), i) = Debug_uninit_major; } @@ -552,6 +554,12 @@ CAMLexport value caml_alloc_shr_with_profinfo (mlsize_t wosize, tag_t tag, return check_oom(caml_alloc_shr_aux(wosize, tag, 1, profinfo)); } +CAMLexport value caml_alloc_shr_reserved (mlsize_t wosize, tag_t tag, + reserved_t reserved) +{ + return caml_alloc_shr_with_profinfo(wosize, tag, reserved); +} + CAMLexport value caml_alloc_shr_for_minor_gc (mlsize_t wosize, tag_t tag, header_t old_hd) { diff --git a/runtime4/minor_gc.c b/runtime4/minor_gc.c index 4c1b8a0152d..973be3cc306 100644 --- a/runtime4/minor_gc.c +++ b/runtime4/minor_gc.c @@ -216,17 +216,24 @@ void caml_oldify_one (value v, value *p) value field0; sz = Wosize_hd (hd); + mlsize_t scannable_sz = Scannable_wosize_hd(hd); result = caml_alloc_shr_for_minor_gc (sz, tag, hd); *p = result; + /* Copy the non-scannable suffix of fields */ + for (i = scannable_sz; i < sz; i++) { + Field(result, i) = Field(v, i); + } field0 = Field (v, 0); Hd_val (v) = 0; /* Set forward flag */ Field (v, 0) = result; /* and forward pointer. */ - if (sz > 1){ + if (scannable_sz == 0) { + return; + } else if (scannable_sz > 1){ Field (result, 0) = field0; Field (result, 1) = oldify_todo_list; /* Add this block */ oldify_todo_list = v; /* to the "to do" list. */ }else{ - CAMLassert (sz == 1); + CAMLassert (scannable_sz == 1); p = &Field (result, 0); v = field0; goto tail_call; @@ -319,11 +326,21 @@ void caml_oldify_mopup (void) new_v = Field (v, 0); /* Follow forward pointer. */ oldify_todo_list = Field (new_v, 1); /* Remove from list. */ + mlsize_t scannable_wosize = Scannable_wosize_val(new_v); + + /* [v] was only added to the [todo_list] if its [scannable_wosize > 1]. + - It needs to be greater than 0 because we oldify the first field. + - It needs to be greater than 1 so the below loop runs at least once, + overwriting Field(new_v, 1) which [oldify_one] used as temporary + storage of the next value of [todo_list]. + */ + CAMLassert (scannable_wosize > 1); + f = Field (new_v, 0); if (Is_block (f) && Is_young (f)){ caml_oldify_one (f, &Field (new_v, 0)); } - for (i = 1; i < Wosize_val (new_v); i++){ + for (i = 1; i < scannable_wosize; i++){ f = Field (v, i); if (Is_block (f) && Is_young (f)){ caml_oldify_one (f, &Field (new_v, i)); @@ -333,6 +350,8 @@ void caml_oldify_mopup (void) } } + // The non-scannable suffix is already copied in [oldify_one]. + /* Oldify the data in the minor heap of alive ephemeron During minor collection keys outside the minor heap are considered alive */ for (re = Caml_state->ephe_ref_table->base; diff --git a/runtime4/misc.c b/runtime4/misc.c index 30331c7dbd7..1f760d74711 100644 --- a/runtime4/misc.c +++ b/runtime4/misc.c @@ -58,6 +58,8 @@ void caml_failed_assert (char * expr, char_os * file_os, int line) void caml_set_fields (value v, uintnat start, uintnat filler) { mlsize_t i; + /* We use Wosize_val instead of Scannable_wosize_val because it's fine to set + even unscannable fields. */ for (i = start; i < Wosize_val (v); i++){ Field (v, i) = (value) filler; } diff --git a/runtime4/obj.c b/runtime4/obj.c index a3513278ef7..1788d96796f 100644 --- a/runtime4/obj.c +++ b/runtime4/obj.c @@ -163,14 +163,25 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg) res = caml_alloc(sz, tg); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); } else if (sz <= Max_young_wosize) { - res = caml_alloc_small(sz, tg); + reserved_t reserved = Reserved_val(arg); + res = caml_alloc_small_with_reserved(sz, tg, reserved); for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); } else { - res = caml_alloc_shr(sz, tg); + mlsize_t scannable_sz = Scannable_wosize_val(arg); + reserved_t reserved = Reserved_val(arg); + + res = caml_alloc_shr_reserved(sz, tg, reserved); /* It is safe to use [caml_initialize] even if [tag == Closure_tag] and some of the "values" being copied are actually code pointers. That's because the new "value" does not point to the minor heap. */ - for (i = 0; i < sz; i++) caml_initialize(&Field(res, i), Field(arg, i)); + for (i = 0; i < scannable_sz; i++) { + caml_initialize(&Field(res, i), Field(arg, i)); + } + + for (i = scannable_sz; i < sz; i++) { + Field(res, i) = Field(arg, i); + } + /* Give gc a chance to run, and run memprof callbacks */ caml_process_pending_actions(); } diff --git a/runtime4/roots_nat.c b/runtime4/roots_nat.c index db449c36cb0..fefc75ac760 100644 --- a/runtime4/roots_nat.c +++ b/runtime4/roots_nat.c @@ -292,9 +292,11 @@ void caml_register_dyn_global(void *v) { caml_dyn_globals = cons((void*) v,caml_dyn_globals); } -/* Logic to determine at which index within a global root to start - scanning. [*glob_block] and [*start] may be updated by this function. */ -static void compute_index_for_global_root_scan (value* glob_block, int* start) +/* Logic to determine at which index within a global root to start and stop + scanning. [*glob_block], [*start], and [*stop] may be updated by this + function. */ + static void compute_index_for_global_root_scan(value* glob_block, int* start, + int* stop) { *start = 0; @@ -309,12 +311,17 @@ static void compute_index_for_global_root_scan (value* glob_block, int* start) cause a failure. */ if (Tag_val (*glob_block) == Infix_tag) *glob_block -= Infix_offset_val (*glob_block); - if (Tag_val (*glob_block) == Closure_tag) + if (Tag_val (*glob_block) == Closure_tag) { *start = Start_env_closinfo (Closinfo_val (*glob_block)); + *stop = Wosize_val(*glob_block); + } + else { + *stop = Scannable_wosize_val(*glob_block); + } } else { /* Set the index such that none of the block's fields will be scanned. */ - *start = Wosize_val (*glob_block); + *stop = 0; } } @@ -325,7 +332,7 @@ void caml_oldify_local_roots (void) intnat i, j; value * glob; value glob_block; - int start; + int start, stop; link *lnk; /* The global roots */ @@ -334,8 +341,8 @@ void caml_oldify_local_roots (void) i++) { for(glob = caml_globals[i]; *glob != 0; glob++) { glob_block = *glob; - compute_index_for_global_root_scan (&glob_block, &start); - for (j = start; j < Wosize_val (glob_block); j++) + compute_index_for_global_root_scan (&glob_block, &start, &stop); + for (j = start; j < stop; j++) Oldify (&Field (glob_block, j)); } } @@ -345,8 +352,8 @@ void caml_oldify_local_roots (void) iter_list(caml_dyn_globals, lnk) { for(glob = (value *) lnk->data; *glob != 0; glob++) { glob_block = *glob; - compute_index_for_global_root_scan (&glob_block, &start); - for (j = start; j < Wosize_val (glob_block); j++) { + compute_index_for_global_root_scan (&glob_block, &start, &stop); + for (j = start; j < stop; j++) { Oldify (&Field (glob_block, j)); } } @@ -390,6 +397,7 @@ intnat caml_darken_all_roots_slice (intnat work) static int do_resume = 0; static value glob_block; static int start; + static int stop; static mlsize_t roots_count = 0; intnat remaining_work = work; CAML_EV_BEGIN(EV_MAJOR_MARK_GLOBAL_ROOTS_SLICE); @@ -402,8 +410,8 @@ intnat caml_darken_all_roots_slice (intnat work) for (i = 0; caml_globals[i] != 0; i++) { for(glob = caml_globals[i]; *glob != 0; glob++) { glob_block = *glob; - compute_index_for_global_root_scan (&glob_block, &start); - for (j = start; j < Wosize_val (glob_block); j++) { + compute_index_for_global_root_scan (&glob_block, &start, &stop); + for (j = start; j < stop; j++) { caml_darken (Field (glob_block, j), &Field (glob_block, j)); -- remaining_work; if (remaining_work == 0){ @@ -434,7 +442,7 @@ void caml_do_roots (scanning_action f, int do_globals) value * glob; link *lnk; value glob_block; - int start; + int start, stop; CAML_EV_BEGIN(EV_MAJOR_ROOTS_DYNAMIC_GLOBAL); if (do_globals){ @@ -442,8 +450,8 @@ void caml_do_roots (scanning_action f, int do_globals) for (i = 0; caml_globals[i] != 0; i++) { for(glob = caml_globals[i]; *glob != 0; glob++) { glob_block = *glob; - compute_index_for_global_root_scan (&glob_block, &start); - for (j = start; j < Wosize_val (glob_block); j++) + compute_index_for_global_root_scan (&glob_block, &start, &stop); + for (j = start; j < stop; j++) f (Field (glob_block, j), &Field (glob_block, j)); } } @@ -452,8 +460,8 @@ void caml_do_roots (scanning_action f, int do_globals) iter_list(caml_dyn_globals, lnk) { for(glob = (value *) lnk->data; *glob != 0; glob++) { glob_block = *glob; - compute_index_for_global_root_scan (&glob_block, &start); - for (j = start; j < Wosize_val (glob_block); j++) { + compute_index_for_global_root_scan (&glob_block, &start, &stop); + for (j = start; j < stop; j++) { f (Field (glob_block, j), &Field (glob_block, j)); } } @@ -570,7 +578,7 @@ static void do_local_allocations(caml_local_arenas* loc, i = 0; if (Tag_hd(hd) == Closure_tag) i = Start_env_closinfo(Closinfo_val(Val_hp(hp))); - for (; i < Wosize_hd(hd); i++) { + for (; i < Scannable_wosize_hd(hd); i++) { value *p = &Field(Val_hp(hp), i); int marked_local = visit(maj, min, p); if (marked_local) { diff --git a/runtime4/weak.c b/runtime4/weak.c index dc0d061270a..a93fe979aa3 100644 --- a/runtime4/weak.c +++ b/runtime4/weak.c @@ -398,27 +398,34 @@ CAMLprim value caml_ephe_get_data (value ar) static void copy_value(value src, value dst) { - mlsize_t sz, i; - sz = Wosize_val(src); + mlsize_t scan_from, scan_to; if (Tag_val (src) >= No_scan_tag) { /* Direct copy */ - memcpy (Bp_val (dst), Bp_val (src), Bsize_wsize (sz)); + memcpy (Bp_val (dst), Bp_val (src), Bosize_val(src)); return; } - i = 0; if (Tag_val (src) == Closure_tag) { /* Direct copy of the code pointers and closure info fields */ - i = Start_env_closinfo(Closinfo_val(src)); - memcpy (Bp_val (dst), Bp_val (src), Bsize_wsize (i)); + scan_from = Start_env_closinfo(Closinfo_val(src)); + scan_to = Wosize_val(src); + memcpy (Bp_val (dst), Bp_val (src), Bsize_wsize (scan_from)); + } else { + scan_from = 0; + scan_to = Scannable_wosize_val(src); } /* Field-by-field copy and darkening of the remaining fields */ - for (/*nothing*/; i < sz; i++){ + for (mlsize_t i = scan_from; i < scan_to; i++){ value f = Field (src, i); if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){ caml_darken (f, NULL); } caml_modify (&Field (dst, i), f); } + + /* Copy non-scannable suffix */ + memcpy (Op_val(dst) + scan_to, + Op_val(src) + scan_to, + Bsize_wsize(Wosize_val(src) - scan_to)); } CAMLexport int caml_ephemeron_get_key_copy(value ar, mlsize_t offset, @@ -464,7 +471,8 @@ CAMLexport int caml_ephemeron_get_key_copy(value ar, mlsize_t offset, caml_minor_collection (); } else { /* cases where loop is between 0 to 7 and where loop is equal to 9 */ - elt = caml_alloc (Wosize_val (v), Tag_val (v)); + elt = caml_alloc_with_reserved (Wosize_val (v), Tag_val (v), + Reserved_val (v)); /* The GC may erase, move or even change v during this call to caml_alloc. */ } @@ -521,7 +529,8 @@ CAMLexport int caml_ephemeron_get_data_copy (value ar, value *data) caml_minor_collection (); } else { /* cases where loop is between 0 to 7 and where loop is equal to 9 */ - elt = caml_alloc (Wosize_val (v), Tag_val (v)); + elt = caml_alloc_with_reserved (Wosize_val (v), Tag_val (v), + Reserved_val (v)); /** cf caml_ephemeron_get_key_copy */ } ++loop; diff --git a/testsuite/tests/mixed-blocks/generate_mixed_blocks_code.ml b/testsuite/tests/mixed-blocks/generate_mixed_blocks_code.ml index 2975fb64cd4..99f6a30ae01 100644 --- a/testsuite/tests/mixed-blocks/generate_mixed_blocks_code.ml +++ b/testsuite/tests/mixed-blocks/generate_mixed_blocks_code.ml @@ -289,10 +289,14 @@ let main n ~bytecode = in let per_type f = List.iter named_blocks ~f in line {|(* TEST - flags = "-extension layouts_alpha"; - runtime5; - %s; -*)|} (if bytecode then "bytecode" else "native"); + flags = "-extension layouts_alpha";|}; + if bytecode then ( + line {| bytecode;|}; + ) else ( + line {| flambda2;|}; + line {| native;|}; + ); + line {|*)|}; line "(** This is code generated by [generate_mixed_blocks_code.ml]. *)"; line ""; line "(* Helper functions for manipulating the fields of a mixed record *)"; diff --git a/testsuite/tests/mixed-blocks/generated_byte_test.ml b/testsuite/tests/mixed-blocks/generated_byte_test.ml index 64584d041ee..541a6398cc2 100644 --- a/testsuite/tests/mixed-blocks/generated_byte_test.ml +++ b/testsuite/tests/mixed-blocks/generated_byte_test.ml @@ -1,6 +1,5 @@ (* TEST flags = "-extension layouts_alpha"; - runtime5; bytecode; *) (** This is code generated by [generate_mixed_blocks_code.ml]. *) diff --git a/testsuite/tests/mixed-blocks/generated_native_test.ml b/testsuite/tests/mixed-blocks/generated_native_test.ml index ea61e5e3ce3..df664b7c8ed 100644 --- a/testsuite/tests/mixed-blocks/generated_native_test.ml +++ b/testsuite/tests/mixed-blocks/generated_native_test.ml @@ -1,6 +1,6 @@ (* TEST flags = "-extension layouts_alpha"; - runtime5; + flambda2; native; *) (** This is code generated by [generate_mixed_blocks_code.ml]. *) diff --git a/testsuite/tests/mixed-blocks/hash.ml b/testsuite/tests/mixed-blocks/hash.ml index a8a5950e9a5..dbb671da343 100644 --- a/testsuite/tests/mixed-blocks/hash.ml +++ b/testsuite/tests/mixed-blocks/hash.ml @@ -2,7 +2,7 @@ flags = "-extension layouts_alpha"; program = "${test_build_directory}/hash.exe"; all_modules = "hash.ml"; - runtime5; + flambda2; { setup-ocamlc.opt-build-env; ocamlc.opt; @@ -42,7 +42,7 @@ let () = |> printf "\t{ x : float; y : float# } = %d\n" -let () = +let () = let open struct type t = { x : float#; diff --git a/testsuite/tests/mixed-blocks/recursive_mixed_blocks.ml b/testsuite/tests/mixed-blocks/recursive_mixed_blocks.ml index d1dc7f729f9..b89875ce454 100644 --- a/testsuite/tests/mixed-blocks/recursive_mixed_blocks.ml +++ b/testsuite/tests/mixed-blocks/recursive_mixed_blocks.ml @@ -1,6 +1,6 @@ (* TEST flags = "-extension layouts_alpha"; - runtime5; + flambda2; { native; }{ diff --git a/testsuite/tests/mixed-blocks/test_mixed_blocks.ml b/testsuite/tests/mixed-blocks/test_mixed_blocks.ml index 80cfc6ae685..349e96e1623 100644 --- a/testsuite/tests/mixed-blocks/test_mixed_blocks.ml +++ b/testsuite/tests/mixed-blocks/test_mixed_blocks.ml @@ -1,5 +1,4 @@ (* TEST - runtime5; reference = "${test_source_directory}/test_mixed_blocks.reference"; flambda2; { diff --git a/testsuite/tests/mixed-blocks/test_printing.ml b/testsuite/tests/mixed-blocks/test_printing.ml index 932f257439a..7c9fe6ab91b 100644 --- a/testsuite/tests/mixed-blocks/test_printing.ml +++ b/testsuite/tests/mixed-blocks/test_printing.ml @@ -1,6 +1,5 @@ (* TEST flags = "-extension layouts_alpha"; - runtime5; expect; *) diff --git a/testsuite/tests/mixed-blocks/test_runtime_4.ml b/testsuite/tests/mixed-blocks/test_runtime_4.ml deleted file mode 100644 index 49d7cd24149..00000000000 --- a/testsuite/tests/mixed-blocks/test_runtime_4.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* TEST - flags = "-extension layouts_alpha"; - runtime4; - expect; -*) - -(* Mixed blocks aren't supported in runtime 4 (yet). When they are, we can - remove this test and remove the preludes from other tests that run them for - just runtime 5. -*) - -type t = - { x : float; - y : float#; - } - -[%%expect{| -Lines 1-4, characters 0-3: -1 | type t = -2 | { x : float; -3 | y : float#; -4 | } -Error: This OCaml runtime doesn't support mixed records. -|}] - -type t = - { x : string; - y : float#; - } - -[%%expect{| -Lines 1-4, characters 0-3: -1 | type t = -2 | { x : string; -3 | y : float#; -4 | } -Error: This OCaml runtime doesn't support mixed records. -|}] diff --git a/testsuite/tests/mixed-blocks/typing_recursive_mixed_blocks.ml b/testsuite/tests/mixed-blocks/typing_recursive_mixed_blocks.ml index cefe0cc7d8f..bce0e2ed463 100644 --- a/testsuite/tests/mixed-blocks/typing_recursive_mixed_blocks.ml +++ b/testsuite/tests/mixed-blocks/typing_recursive_mixed_blocks.ml @@ -1,6 +1,5 @@ (* TEST flags = "-extension layouts_alpha"; - runtime5; expect; *) diff --git a/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml b/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml index 9cb933769c8..10b71838625 100644 --- a/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml +++ b/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml @@ -1,5 +1,4 @@ (* TEST - runtime5; reference = "${test_source_directory}/unboxed_floats_alpha.reference"; flambda2; { diff --git a/testsuite/tests/typing-layouts/mixed_records.ml b/testsuite/tests/typing-layouts/mixed_records.ml index bd2c40f8f8c..67453f3e2f5 100644 --- a/testsuite/tests/typing-layouts/mixed_records.ml +++ b/testsuite/tests/typing-layouts/mixed_records.ml @@ -1,5 +1,4 @@ (* TEST - runtime5; expect; *) diff --git a/testsuite/tests/typing-layouts/mixed_records_alpha.ml b/testsuite/tests/typing-layouts/mixed_records_alpha.ml index 996393ba4ae..ca9f26c462a 100644 --- a/testsuite/tests/typing-layouts/mixed_records_alpha.ml +++ b/testsuite/tests/typing-layouts/mixed_records_alpha.ml @@ -1,6 +1,5 @@ (* TEST flags = "-extension layouts_alpha"; - runtime5; expect; *) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 73c3fca63a3..c6401b9c7f0 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1153,8 +1153,7 @@ let assert_mixed_record_support = if not (Language_extension.is_at_least Layouts required_layouts_level) then raise (Error (loc, Illegal_mixed_record (Insufficient_level { required_layouts_level }))); - if Config.reserved_header_bits < required_reserved_header_bits - || not Config.runtime5 then + if Config.reserved_header_bits < required_reserved_header_bits then raise (Error (loc, Illegal_mixed_record Runtime_support_not_enabled)); if value_prefix_len > max_value_prefix_len then raise