flambda-backend: Fix mixed-block-related segfault in runtime4's `reda…

…rken_chunk` (#2605)

* Fix segfault in redarken_chunk

* Fix issues in (deprecated) Obj.truncate and in debug heap verification

* More extensive fix to runtime4 realloc issue

runtime4/caml/major_gc.h

@@ -22,11 +22,16 @@
 #include "misc.h"
 
 /* An interval of a single object to be scanned.
-   The end pointer must always be one-past-the-end of a heap block,
-   but the start pointer is not necessarily the start of the block */
+   The object end pointer must always be one-past-the-end of a heap block,
+   but the start pointer is not necessarily the start of the block,
+   and the scannable end pointer is not necessarily the same as the
+   object end pointer. (The GC should not scan past the scannable
+   end pointer.)
+*/
 typedef struct {
   value* start;
-  value* end;
+  value* scannable_end;
+  value* object_end;
 } mark_entry;
 
 typedef struct {

runtime4/caml/mlvalues.h

@@ -266,6 +266,8 @@ Caml_inline mlsize_t Scannable_wosize_reserved_byte(reserved_t res,
 #define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp)))
 #define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd)))
 
+#define Scannable_wosize_hp(hp) (Scannable_wosize_hd (Hd_hp (hp)))
+
 #define Profinfo_val(val) (Profinfo_hd (Hd_val (val)))
 
 #ifdef ARCH_BIG_ENDIAN

runtime4/major_gc.c

@@ -166,8 +166,8 @@ static void mark_stack_prune (struct mark_stack* stk)
       if (ch->redarken_first.start > me.start)
         ch->redarken_first = me;
 
-      if (ch->redarken_end < me.end)
-        ch->redarken_end = me.end;
+      if (ch->redarken_end < me.object_end)
+        ch->redarken_end = me.object_end;
 
       if( redarken_first_chunk == NULL
           || redarken_first_chunk > (char*)chunk_addr ) {
@@ -214,14 +214,15 @@ Caml_inline void mark_stack_push(struct mark_stack* stk, value block,
                                   uintnat offset, intnat* work)
 {
   value v;
-  int i, block_scannable_wsz, end;
+  int i, block_scannable_wsz, block_wsz, end;
   mark_entry* me;
 
   CAMLassert(Is_block(block) && Is_in_heap (block)
             && Is_black_val(block));
   CAMLassert(Tag_val(block) != Infix_tag);
   CAMLassert(Tag_val(block) < No_scan_tag);
 
+  block_wsz = Wosize_val(block);
   block_scannable_wsz = Scannable_wosize_val(block);
 
 #if defined(NO_NAKED_POINTERS) || defined(NAKED_POINTERS_CHECKER)
@@ -275,7 +276,8 @@ 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) + block_scannable_wsz;
+  me->scannable_end = Op_val(block) + block_scannable_wsz;
+  me->object_end = Op_val(block) + block_wsz;
 }
 
 #if defined(NAKED_POINTERS_CHECKER) && defined(NATIVE_CODE)
@@ -352,14 +354,15 @@ static int redarken_chunk(char* heap_chunk, struct mark_stack* stk) {
   while (1) {
     header_t* hp;
     /* Skip a prefix of fields that need no marking */
-    CAMLassert(me.start <= me.end && (header_t*)me.end <= end);
-    while (me.start < me.end &&
+    CAMLassert(me.start <= me.scannable_end &&
+               (header_t*)me.scannable_end <= end);
+    while (me.start < me.scannable_end &&
            (!Is_block(*me.start) || Is_young(*me.start))) {
       me.start++;
     }
 
     /* Push to the mark stack (if anything's left) */
-    if (me.start < me.end) {
+    if (me.start < me.scannable_end) {
       if (stk->count < stk->size/4) {
         stk->stack[stk->count++] = me;
       } else {
@@ -371,7 +374,7 @@ static int redarken_chunk(char* heap_chunk, struct mark_stack* stk) {
     }
 
     /* Find the next block that needs to be re-marked */
-    hp = (header_t*)me.end;
+    hp = (header_t*)me.object_end;
     CAMLassert(hp <= end);
     while (hp < end) {
       value v = Val_hp(hp);
@@ -384,15 +387,17 @@ static int redarken_chunk(char* heap_chunk, struct mark_stack* stk) {
 
     /* Found a block */
     me.start = Op_hp(hp);
-    me.end = me.start + Wosize_hp(hp);
+    me.scannable_end = me.start + Scannable_wosize_hp(hp);
+    me.object_end = me.start + Wosize_hp(hp);
     if (Tag_hp(hp) == Closure_tag) {
       me.start += Start_env_closinfo(Closinfo_val(Val_hp(hp)));
     }
   }
 
   chunk->redarken_first.start =
       (value*)(heap_chunk + Chunk_size(heap_chunk));
-  chunk->redarken_first.end = chunk->redarken_first.start;
+  chunk->redarken_first.scannable_end = chunk->redarken_first.start;
+  chunk->redarken_first.object_end = chunk->redarken_first.start;
   chunk->redarken_end = (value*)heap_chunk;
 
   return 1;
@@ -644,7 +649,17 @@ Caml_noinline static intnat do_some_marking
 #endif
 
   while (1) {
-    value *scan, *obj_end, *scan_end;
+    /* * [scan] is initialized to the point where we should start scanning in
+         the object. It is then updated to keep track of the actual scanning
+         progress.
+       * [obj_scannable_end] is the point up until which it is legal to scan the
+         object.
+       * [obj_end] is a pointer to one past the end of the object.
+       * [scan_end] is where the scanning actually will progress until. It is
+         less than [obj_scannable_end] in the event that the work budget is
+         lower than what would be required to scan until that point.
+     */
+    value *scan, *obj_scannable_end, *obj_end, *scan_end;
     intnat scan_len;
 
     if (pb_enqueued > pb_dequeued + min_pb) {
@@ -672,8 +687,9 @@ Caml_noinline static intnat do_some_marking
         continue;
       }
       scan = Op_val(block);
-      obj_end = scan + Scannable_wosize_hd(hd);
-      work -= Wosize_hd(hd) - Scannable_wosize_hd(hd);
+      obj_scannable_end = scan + Scannable_wosize_hd(hd);
+      obj_end = scan + Wosize_hd(hd);
+      work -= obj_end - obj_scannable_end;
 
       if (Tag_hd (hd) == Closure_tag) {
         uintnat env_offset = Start_env_closinfo(Closinfo_val(block));
@@ -693,10 +709,11 @@ Caml_noinline static intnat do_some_marking
     } else {
       mark_entry m = stk.stack[--stk.count];
       scan = m.start;
-      obj_end = m.end;
+      obj_scannable_end = m.scannable_end;
+      obj_end = m.object_end;
     }
 
-    scan_len = obj_end - scan;
+    scan_len = obj_scannable_end - scan;
     if (work < scan_len) {
       scan_len = work;
       if (scan_len < 0) scan_len = 0;
@@ -728,10 +745,10 @@ Caml_noinline static intnat do_some_marking
 #endif
     }
 
-    if (scan < obj_end) {
+    if (scan < obj_scannable_end) {
       /* Didn't finish scanning this object, either because work <= 0,
          or the prefetch buffer filled up. Leave the rest on the stack. */
-      mark_entry m = { scan, obj_end };
+      mark_entry m = { scan, obj_scannable_end, obj_end };
       caml_prefetch(scan+1);
       if (stk.count == stk.size) {
         *Caml_state->mark_stack = stk;
@@ -740,7 +757,8 @@ Caml_noinline static intnat do_some_marking
       }
       CAML_EVENTLOG_DO({
         if (work <= 0 && pb_enqueued == pb_dequeued) {
-          CAML_EV_COUNTER(EV_C_MAJOR_MARK_SLICE_REMAIN, obj_end - scan);
+          CAML_EV_COUNTER(EV_C_MAJOR_MARK_SLICE_REMAIN,
+                          obj_scannable_end - scan);
         }
       });
       stk.stack[stk.count++] = m;

runtime4/memory.c

@@ -306,7 +306,9 @@ char *caml_alloc_for_heap (asize_t request)
     Chunk_block (mem) = block;
   }
   Chunk_head (mem)->redarken_first.start = (value*)(mem + Chunk_size(mem));
-  Chunk_head (mem)->redarken_first.end = (value*)(mem + Chunk_size(mem));
+  Chunk_head (mem)->redarken_first.scannable_end =
+    (value*)(mem + Chunk_size(mem));
+  Chunk_head (mem)->redarken_first.object_end = (value*)(mem + Chunk_size(mem));
   Chunk_head (mem)->redarken_end = (value*)mem;
   return mem;
 }

runtime4/minor_gc.c

@@ -402,7 +402,7 @@ static void verify_minor_heap(void)
       intnat i = 0;
       if (Tag_hd(hd) == Closure_tag)
         i = Start_env_closinfo(Closinfo_val(Val_hp(p)));
-      for (; i < Wosize_hd(hd); i++) {
+      for (; i < Scannable_wosize_hd(hd); i++) {
         value v = Field(Val_hp(p), i);
         if (Is_block(v)) {
           if (Is_young(v)) CAMLassert ((value)Caml_state->young_ptr < v);

runtime4/obj.c

@@ -230,12 +230,22 @@ CAMLprim value caml_obj_truncate (value v, value newsize)
      beyond new_wosize in v, erase them explicitly so that the GC
      can darken them as appropriate. */
   if (tag < No_scan_tag) {
-    for (i = new_wosize; i < wosize; i++){
+    mlsize_t scannable_wosize = Scannable_wosize_hd(hd);
+    for (i = new_wosize; i < scannable_wosize; i++){
       caml_modify(&Field(v, i), Val_unit);
 #ifdef DEBUG
       Field (v, i) = Debug_free_truncate;
 #endif
     }
+#ifdef DEBUG
+    /* Unless we're in debug mode, it's not necessary to empty out
+       the non-scannable suffix, as the GC knows not to look there
+       anyway.
+     */
+    for (; i < wosize; i++) {
+      Field (v, i) = Debug_free_truncate;
+    }
+#endif
   }
   /* We must use an odd tag for the header of the leftovers so it does not
      look like a pointer because there may be some references to it in