Garbage collector colours change (#9756)

Changes

@@ -24,6 +24,11 @@ Working version
 
 ### Runtime system:
 
+- #9756: garbage collector colors change
+  removes the gray color from the major gc
+  (Sadiq Jaffer and Stephen Dolan reviewed by Xavier Leroy,
+  KC Sivaramakrishnan, Damien Doligez and Jacques-Henri Jourdan)
+
 - #1795, #9543: modernize signal handling on Linux i386, PowerPC, and s390x,
   adding support for Musl ppc64le along the way.
   (Xavier Leroy and Anil Madhavapeddy, review by Stephen Dolan)

runtime/caml/domain_state.tbl

@@ -36,6 +36,9 @@ DOMAIN_STATE(struct caml_ephe_ref_table*, ephe_ref_table)
 DOMAIN_STATE(struct caml_custom_table*, custom_table)
 /* See minor_gc.c */
 
+DOMAIN_STATE(struct mark_stack*, mark_stack)
+/* See major_gc.c */
+
 DOMAIN_STATE(value*, stack_low)
 DOMAIN_STATE(value*, stack_high)
 DOMAIN_STATE(value*, stack_threshold)

runtime/caml/gc.h

@@ -68,7 +68,6 @@ extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat);
 #endif
 
 #define Is_white_val(val) (Color_val(val) == Caml_white)
-#define Is_gray_val(val) (Color_val(val) == Caml_gray)
 #define Is_blue_val(val) (Color_val(val) == Caml_blue)
 #define Is_black_val(val) (Color_val(val) == Caml_black)
 

runtime/caml/major_gc.h

@@ -26,12 +26,16 @@ typedef struct {
   asize_t alloc;         /* in bytes, used for compaction */
   asize_t size;          /* in bytes */
   char *next;
+  value* redarken_start;  /* first block in chunk to redarken */
+  value* redarken_end;    /* last block in chunk that needs redarkening */
 } heap_chunk_head;
 
 #define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size
 #define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc
 #define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next
 #define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block
+#define Chunk_redarken_start(c) (((heap_chunk_head *) (c)) [-1]).redarken_start
+#define Chunk_redarken_end(c) (((heap_chunk_head *) (c)) [-1]).redarken_end
 
 extern int caml_gc_phase;
 extern int caml_gc_subphase;
@@ -80,6 +84,7 @@ void caml_init_major_heap (asize_t);           /* size in bytes */
 asize_t caml_clip_heap_chunk_wsz (asize_t wsz);
 void caml_darken (value, value *);
 void caml_major_collection_slice (intnat);
+void caml_shrink_mark_stack ();
 void major_collection (void);
 void caml_finish_major_cycle (void);
 void caml_set_major_window (int);

runtime/compact.c

@@ -368,6 +368,9 @@ static void do_compaction (intnat new_allocation_policy)
     }
   }
   ++ Caml_state->stat_compactions;
+
+  caml_shrink_mark_stack();
+
   caml_gc_message (0x10, "done.\n");
 }
 

runtime/freelist.c

@@ -1670,7 +1670,6 @@ static header_t *bf_merge_block (value bp, char *limit)
     switch (Color_val (cur)){
     case Caml_white: goto white;
     case Caml_blue: bf_remove (cur); goto next;
-    case Caml_gray:
     case Caml_black:
       goto end_of_run;
     }

runtime/gc_ctrl.c

@@ -173,7 +173,7 @@ static value heap_stats (int returnstats)
           }
         }
         break;
-      case Caml_gray: case Caml_black:
+      case Caml_black:
         CAMLassert (Wosize_hd (cur_hd) > 0);
         ++ live_blocks;
         live_words += Whsize_hd (cur_hd);

runtime/major_gc.c

@@ -30,6 +30,7 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 #include "caml/roots.h"
+#include "caml/skiplist.h"
 #include "caml/signals.h"
 #include "caml/weak.h"
 #include "caml/memprof.h"
@@ -41,17 +42,25 @@ Caml_inline double fmin(double a, double b) {
 }
 #endif
 
+#define MARK_STACK_INIT_SIZE 2048
+
+typedef struct {
+  value block;
+  uintnat offset;
+} mark_entry;
+
+struct mark_stack {
+  mark_entry* stack;
+  uintnat count;
+  uintnat size;
+};
+
 uintnat caml_percent_free;
 uintnat caml_major_heap_increment;
 CAMLexport char *caml_heap_start;
 char *caml_gc_sweep_hp;
 int caml_gc_phase;        /* always Phase_mark, Pase_clean,
                              Phase_sweep, or Phase_idle */
-static value *gray_vals;
-static value *gray_vals_cur, *gray_vals_end;
-static asize_t gray_vals_size;
-static int heap_is_pure;   /* The heap is pure if the only gray objects
-                              below [markhp] are also in [gray_vals]. */
 uintnat caml_allocated_words;
 uintnat caml_dependent_size, caml_dependent_allocated;
 double caml_extra_heap_resources;
@@ -59,7 +68,11 @@ uintnat caml_fl_wsz_at_phase_change = 0;
 
 extern value caml_fl_merge;  /* Defined in freelist.c. */
 
-static char *markhp, *chunk, *limit;
+/* redarken_first_chunk is the first chunk needing redarkening, if NULL no
+  redarkening required */
+static char *redarken_first_chunk = NULL;
+
+static char *sweep_chunk, *sweep_limit;
 static double p_backlog = 0.0; /* backlog for the gc speedup parameter */
 
 int caml_gc_subphase;     /* Subphase_{mark_roots,mark_main,mark_final} */
@@ -100,7 +113,7 @@ int caml_gc_subphase;     /* Subphase_{mark_roots,mark_main,mark_final} */
  */
 static int ephe_list_pure;
 /** The ephemerons is pure if since the start of its iteration
-    no value have been darken. */
+    no value have been darkened. */
 static value *ephes_checked_if_pure;
 static value *ephes_to_check;
 
@@ -116,34 +129,150 @@ static unsigned long major_gc_counter = 0;
 
 void (*caml_major_gc_hook)(void) = NULL;
 
-static void realloc_gray_vals (void)
+/* This function prunes the mark stack if it's about to overflow. It does so
+   by building a skiplist of major heap chunks and then iterating through the
+   mark stack and setting redarken_start/redarken_end on each chunk to indicate
+   the range that requires redarkening. */
+static void mark_stack_prune (struct mark_stack* stk)
 {
-  value *new;
+  int entry;
+  uintnat mark_stack_count = stk->count;
+  mark_entry* mark_stack = stk->stack;
 
-  CAMLassert (gray_vals_cur == gray_vals_end);
-  if (gray_vals_size < Caml_state->stat_heap_wsz / 32){
-    caml_gc_message (0x08, "Growing gray_vals to %"
-                           ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
-                     (intnat) gray_vals_size * sizeof (value) / 512);
-    new = (value *) caml_stat_resize_noexc ((char *) gray_vals,
-                                            2 * gray_vals_size *
-                                            sizeof (value));
-    if (new == NULL){
-      caml_gc_message (0x08, "No room for growing gray_vals\n");
-      gray_vals_cur = gray_vals;
-      heap_is_pure = 0;
-    }else{
-      gray_vals = new;
-      gray_vals_cur = gray_vals + gray_vals_size;
-      gray_vals_size *= 2;
-      gray_vals_end = gray_vals + gray_vals_size;
+  char* heap_chunk = caml_heap_start;
+  struct skiplist chunk_sklist = SKIPLIST_STATIC_INITIALIZER;
+
+  do {
+    caml_skiplist_insert(&chunk_sklist, (uintnat)heap_chunk,
+                          (uintnat)(heap_chunk+Chunk_size(heap_chunk)));
+    heap_chunk = Chunk_next(heap_chunk);
+  } while( heap_chunk != NULL );
+
+  for( entry = 0; entry < mark_stack_count ; entry++ ) {
+    mark_entry me = mark_stack[entry];
+    value* block_op = Op_val(me.block);
+    uintnat chunk_addr = 0, chunk_addr_below = 0;
+
+    if( caml_skiplist_find_below(&chunk_sklist, (uintnat)me.block,
+          &chunk_addr, &chunk_addr_below)
+        && me.block < chunk_addr_below ) {
+
+      if( Chunk_redarken_start(chunk_addr) > block_op ) {
+        Chunk_redarken_start(chunk_addr) = block_op;
+      }
+
+      if( Chunk_redarken_end(chunk_addr) < block_op ) {
+        Chunk_redarken_end(chunk_addr) = block_op;
+      }
+
+      if( redarken_first_chunk == NULL
+          || redarken_first_chunk > (char*)chunk_addr ) {
+        redarken_first_chunk = (char*)chunk_addr;
+      }
     }
-  }else{
-    gray_vals_cur = gray_vals + gray_vals_size / 2;
-    heap_is_pure = 0;
   }
+
+  caml_skiplist_empty(&chunk_sklist);
+
+  caml_gc_message(0x08, "Mark stack overflow.\n");
+
+  stk->count = 0;
 }
 
+static void realloc_mark_stack (struct mark_stack* stk)
+{
+  mark_entry* new;
+  uintnat mark_stack_bsize = stk->size * sizeof(mark_entry);
+
+  if ( Wsize_bsize(mark_stack_bsize) < Caml_state->stat_heap_wsz / 64 ) {
+    caml_gc_message (0x08, "Growing mark stack to %"
+                           ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
+                     (intnat) mark_stack_bsize * 2 / 1024);
+
+    new = (mark_entry*) caml_stat_resize_noexc ((char*) stk->stack,
+                                                2 * mark_stack_bsize);
+    if (new != NULL) {
+      stk->stack = new;
+      stk->size *= 2;
+      return;
+    }
+  }
+
+  caml_gc_message (0x08, "No room for growing mark stack. Pruning..\n");
+  mark_stack_prune(stk);
+}
+
+/* This function pushes the provided mark_entry [me] onto the current mark
+   stack [stk]. It first checks, if the block is small enough, whether there
+   are any fields we would actually do mark work on. If so then it enqueues
+   the entry. */
+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;
+  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);
+
+#ifdef NO_NAKED_POINTERS
+  if (Tag_val(block) == Closure_tag) {
+    /* Skip the code pointers and integers at beginning of closure;
+        start scanning at the first word of the environment part. */
+  /* It might be the case that [mark_stack_push] has been called
+      while we are traversing a closure block but have not enough
+      budget to finish the block. In that specific case, we should not
+      update [m.offset] */
+    if (offset == 0)
+      offset = Start_env_closinfo(Closinfo_val(block));
+
+    CAMLassert(offset <= Wosize_val(block)
+      && offset >= Start_env_closinfo(Closinfo_val(block)));
+  }
+#endif
+
+  end = (block_wsz < 8 ? block_wsz : 8);
+
+  /* Optimisation to avoid pushing small, unmarkable objects such as [Some 42]
+   * into the mark stack. */
+  for (i = offset; i < end; i++) {
+    v = Field(block, i);
+
+    if (Is_block(v) && !Is_black_val(v))
+      /* found something to mark */
+      break;
+  }
+
+  if (i == block_wsz) {
+    /* nothing left to mark */
+    if( work != NULL ) {
+      /* we should take credit for it though */
+      *work -= Whsize_wosize(block_wsz - offset);
+    }
+    return;
+  }
+
+  if( work != NULL ) {
+    /* take credit for the work we skipped due to the optimisation.
+       we will take credit for the header later as part of marking. */
+    *work -= (i - offset);
+  }
+
+  offset = i;
+
+  if (stk->count == stk->size)
+    realloc_mark_stack(stk);
+
+  me = &stk->stack[stk->count++];
+
+  me->block = block;
+  me->offset = offset;
+}
+
+
 void caml_darken (value v, value *p /* not used */)
 {
 #ifdef NO_NAKED_POINTERS
@@ -167,26 +296,81 @@ void caml_darken (value v, value *p /* not used */)
     CAMLassert (!Is_blue_hd (h));
     if (Is_white_hd (h)){
       ephe_list_pure = 0;
+      Hd_val (v) = Blackhd_hd (h);
       if (t < No_scan_tag){
-        Hd_val (v) = Grayhd_hd (h);
-        *gray_vals_cur++ = v;
-        if (gray_vals_cur >= gray_vals_end) realloc_gray_vals ();
-      }else{
-        Hd_val (v) = Blackhd_hd (h);
+        mark_stack_push(Caml_state->mark_stack, v, 0, NULL);
       }
     }
   }
 }
 
+/* This function shrinks the mark stack back to the MARK_STACK_INIT_SIZE size
+   and is called at the end of a GC compaction to avoid a mark stack greater
+   than 1/32th of the heap. */
+void caml_shrink_mark_stack () {
+  struct mark_stack* stk = Caml_state->mark_stack;
+  intnat init_stack_bsize = MARK_STACK_INIT_SIZE * sizeof(mark_entry);
+  mark_entry* shrunk_stack;
+
+  caml_gc_message (0x08, "Shrinking mark stack to %"
+                  ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
+                  init_stack_bsize);
+
+  shrunk_stack = (mark_entry*) caml_stat_resize_noexc ((char*) stk->stack,
+                                              init_stack_bsize);
+  if (shrunk_stack != NULL) {
+    stk->stack = shrunk_stack;
+    stk->size = MARK_STACK_INIT_SIZE;
+  }else{
+    caml_gc_message (0x08, "Mark stack shrinking failed");
+  }
+}
+
+/* This function adds blocks in the passed heap chunk [heap_chunk] to
+   the mark stack. It returns 1 when the supplied chunk has no more
+   range to redarken.  It returns 0 if there are still blocks in the
+   chunk that need redarkening because pushing them onto the stack
+   would make it grow more than a quarter full. This is to lower the
+   chance of triggering another overflow, which would be
+   wasteful. Subsequent calls will continue progress.
+ */
+static int redarken_chunk(char* heap_chunk, struct mark_stack* stk) {
+  value* p = Chunk_redarken_start(heap_chunk);
+  value* end = Chunk_redarken_end(heap_chunk);
+
+  while (p <= end) {
+    header_t hd = Hd_op(p);
+
+    if( Is_black_hd(hd) && Tag_hd(hd) < No_scan_tag ) {
+      if( stk->count < stk->size/4 ) {
+        mark_stack_push(stk, Val_op(p), 0, NULL);
+      } else {
+        /* Only fill up a quarter of the mark stack, we can resume later
+           for more if we need to */
+        Chunk_redarken_start(heap_chunk) = p;
+        return 0;
+      }
+    }
+
+    p += Whsize_hp(Hp_op(p));
+  }
+
+  Chunk_redarken_start(heap_chunk) =
+      (value*)(heap_chunk + Chunk_size(heap_chunk));
+
+  Chunk_redarken_end(heap_chunk) = 0;
+  return 1;
+}
+
 static void start_cycle (void)
 {
   CAMLassert (caml_gc_phase == Phase_idle);
-  CAMLassert (gray_vals_cur == gray_vals);
+  CAMLassert (Caml_state->mark_stack->count == 0);
+  CAMLassert (redarken_first_chunk == NULL);
   caml_gc_message (0x01, "Starting new major GC cycle\n");
   caml_darken_all_roots_start ();
   caml_gc_phase = Phase_mark;
   caml_gc_subphase = Subphase_mark_roots;
-  markhp = NULL;
   ephe_list_pure = 1;
   ephes_checked_if_pure = &caml_ephe_list_head;
   ephes_to_check = &caml_ephe_list_head;
@@ -196,13 +380,6 @@ static void start_cycle (void)
 #endif
 }
 
-/* We may stop the slice inside values, in order to avoid large latencies
-   on large arrays. In this case, [current_value] is the partially-marked
-   value and [current_index] is the index of the next field to be marked.
-*/
-static value current_value = 0;
-static mlsize_t current_index = 0;
-
 static void init_sweep_phase(void)
 {
   /* Phase_clean is done. */
@@ -210,17 +387,17 @@ static void init_sweep_phase(void)
   caml_gc_sweep_hp = caml_heap_start;
   caml_fl_init_merge ();
   caml_gc_phase = Phase_sweep;
-  chunk = caml_heap_start;
-  caml_gc_sweep_hp = chunk;
-  limit = chunk + Chunk_size (chunk);
+  sweep_chunk = caml_heap_start;
+  caml_gc_sweep_hp = sweep_chunk;
+  sweep_limit = sweep_chunk + Chunk_size (sweep_chunk);
   caml_fl_wsz_at_phase_change = caml_fl_cur_wsz;
   if (caml_major_gc_hook) (*caml_major_gc_hook)();
 }
 
 /* auxiliary function of mark_slice */
-Caml_inline value* mark_slice_darken(value *gray_vals_ptr,
-                                     value v, mlsize_t i,
-                                     int in_ephemeron, int *slice_pointers)
+Caml_inline void mark_slice_darken(struct mark_stack* stk, value v, mlsize_t i,
+                                       int in_ephemeron, int *slice_pointers,
+                                       intnat *work)
 {
   value child;
   header_t chd;
@@ -228,7 +405,7 @@ Caml_inline value* mark_slice_darken(value *gray_vals_ptr,
   child = Field (v, i);
 
 #ifdef NO_NAKED_POINTERS
-  if (Is_block (child) && ! Is_young (child)) {
+  if (Is_block (child) && !Is_young (child)) {
 #else
   if (Is_block (child) && Is_in_heap (child)) {
 #endif
@@ -267,20 +444,17 @@ Caml_inline value* mark_slice_darken(value *gray_vals_ptr,
 #endif
     if (Is_white_hd (chd)){
       ephe_list_pure = 0;
-      Hd_val (child) = Grayhd_hd (chd);
-      *gray_vals_ptr++ = child;
-      if (gray_vals_ptr >= gray_vals_end) {
-        gray_vals_cur = gray_vals_ptr;
-        realloc_gray_vals ();
-        gray_vals_ptr = gray_vals_cur;
+      Hd_val (child) = Blackhd_hd (chd);
+      if( Tag_hd(chd) < No_scan_tag ) {
+        mark_stack_push(stk, child, 0, work);
+      } else {
+        *work -= 1; /* Account for header */
       }
     }
   }
-
-  return gray_vals_ptr;
 }
 
-static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
+static void mark_ephe_aux (struct mark_stack *stk, intnat *work,
                              int *slice_pointers)
 {
   value v, data, key;
@@ -342,13 +516,11 @@ static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
     *work -= Whsize_wosize(i);
 
     if (alive_data){
-      gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,
-                                        CAML_EPHE_DATA_OFFSET,
-                                        /*in_ephemeron=*/1,
-                                        slice_pointers);
+      mark_slice_darken(stk, v, CAML_EPHE_DATA_OFFSET, /*in_ephemeron=*/1,
+                          slice_pointers, work);
     } else { /* not triggered move to the next one */
       ephes_to_check = &Field(v,CAML_EPHE_LINK_OFFSET);
-      return gray_vals_ptr;
+      return;
     }
   } else {  /* a simily weak pointer or an already alive data */
     *work -= 1;
@@ -368,119 +540,80 @@ static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
     *ephes_checked_if_pure = v;
     ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET);
   }
-  return gray_vals_ptr;
 }
 
 
 
 static void mark_slice (intnat work)
 {
-  value *gray_vals_ptr;  /* Local copy of [gray_vals_cur] */
-  value v;
-  header_t hd;
-  mlsize_t size, i, start, end; /* [start] is a local copy of [current_index] */
+  mark_entry me = {0, 0};
+  mlsize_t me_end = 0;
 #ifdef CAML_INSTR
   int slice_fields = 0; /** eventlog counters */
 #endif /*CAML_INSTR*/
   int slice_pointers = 0;
+  struct mark_stack* stk = Caml_state->mark_stack;
 
   caml_gc_message (0x40, "Marking %"ARCH_INTNAT_PRINTF_FORMAT"d words\n", work);
   caml_gc_message (0x40, "Subphase = %d\n", caml_gc_subphase);
-  gray_vals_ptr = gray_vals_cur;
-  v = current_value;
-  start = current_index;
-  while (work > 0){
-    if (v == 0 && gray_vals_ptr > gray_vals){
-      CAMLassert (start == 0);
-      v = *--gray_vals_ptr;
-      CAMLassert (Is_gray_val (v));
-#ifdef NO_NAKED_POINTERS
-      if (Tag_val(v) == Closure_tag) {
-        /* Skip the code pointers and integers at beginning of closure;
-           start scanning at the first word of the environment part. */
-        start = Start_env_closinfo(Closinfo_val(v));
-        CAMLassert(start <= Wosize_val(v));
+
+  while (1){
+    int can_mark = 0;
+
+    if (me.offset == me_end) {
+      if (stk->count > 0)
+      {
+        me = stk->stack[--stk->count];
+        me_end = Wosize_val(me.block);
+        can_mark = 1;
       }
-#endif
+    } else {
+      can_mark = 1;
     }
-    if (v != 0){
-      hd = Hd_val(v);
-      CAMLassert (Is_gray_hd (hd));
-      size = Wosize_hd (hd);
-      end = start + work;
-      if (Tag_hd (hd) < No_scan_tag){
-        start = size < start ? size : start;
-        end = size < end ? size : end;
-        CAMLassert (end >= start);
+
+    if (work <= 0) {
+      if( can_mark ) {
+        mark_stack_push(stk, me.block, me.offset, NULL);
         CAML_EVENTLOG_DO({
-          slice_fields += end - start;
-          if (size > end)
-            CAML_EV_COUNTER (EV_C_MAJOR_MARK_SLICE_REMAIN, size - end);
+          CAML_EV_COUNTER(EV_C_MAJOR_MARK_SLICE_REMAIN, me_end - me.offset);
         });
-        for (i = start; i < end; i++){
-          gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,i,
-                                            /*in_ephemeron=*/ 0,
-                                            &slice_pointers);
-        }
-        if (end < size){
-          work = 0;
-          start = end;
-          /* [v] doesn't change. */
-          CAMLassert (Is_gray_val (v));
-        }else{
-          CAMLassert (end == size);
-          Hd_val (v) = Blackhd_hd (hd);
-          work -= Whsize_wosize(end - start);
-          start = 0;
-          v = 0;
-        }
-      }else{
-        /* The block doesn't contain any pointers. */
-        CAMLassert (start == 0);
-        Hd_val (v) = Blackhd_hd (hd);
-        work -= Whsize_wosize(size);
-        v = 0;
       }
-    }else if (markhp != NULL){
-      if (markhp == limit){
-        chunk = Chunk_next (chunk);
-        if (chunk == NULL){
-          markhp = NULL;
-        }else{
-          markhp = chunk;
-          limit = chunk + Chunk_size (chunk);
-        }
-      }else{
-        if (Is_gray_val (Val_hp (markhp))){
-          CAMLassert (gray_vals_ptr == gray_vals);
-          CAMLassert (v == 0 && start == 0);
-          v = Val_hp (markhp);
-#ifdef NO_NAKED_POINTERS
-          if (Tag_val(v) == Closure_tag) {
-            start = Start_env_closinfo(Closinfo_val(v));
-            CAMLassert(start <= Wosize_val(v));
-          }
-#endif
-        }
-        markhp += Bhsize_hp (markhp);
+      break;
+    }
+
+    if( can_mark ) {
+      CAMLassert(Is_block(me.block) &&
+                 Is_black_val (me.block) &&
+                 Tag_val(me.block) < No_scan_tag);
+
+      mark_slice_darken(stk, me.block, me.offset++, /*in_ephemeron=*/ 0,
+                                              &slice_pointers, &work);
+
+      work--;
+
+      CAML_EVENTLOG_DO({
+        slice_fields++;
+      });
+
+      if( me.offset == me_end ) {
+        work--; /* Include header word */
+      }
+    } else if( redarken_first_chunk != NULL ) {
+      /* There are chunks that need to be redarkened because we
+         overflowed our mark stack */
+      if( redarken_chunk(redarken_first_chunk, stk) ) {
+        redarken_first_chunk = Chunk_next(redarken_first_chunk);
       }
-    }else if (!heap_is_pure){
-      heap_is_pure = 1;
-      chunk = caml_heap_start;
-      markhp = chunk;
-      limit = chunk + Chunk_size (chunk);
     } else if (caml_gc_subphase == Subphase_mark_roots) {
       CAML_EV_BEGIN(EV_MAJOR_MARK_ROOTS);
-      gray_vals_cur = gray_vals_ptr;
       work = caml_darken_all_roots_slice (work);
-      gray_vals_ptr = gray_vals_cur;
       CAML_EV_END(EV_MAJOR_MARK_ROOTS);
       if (work > 0){
         caml_gc_subphase = Subphase_mark_main;
       }
     } else if (*ephes_to_check != (value) NULL) {
       /* Continue to scan the list of ephe */
-      gray_vals_ptr = mark_ephe_aux(gray_vals_ptr,&work,&slice_pointers);
+      mark_ephe_aux(stk,&work,&slice_pointers);
     } else if (!ephe_list_pure){
       /* We must scan again the list because some value have been darken */
       ephe_list_pure = 1;
@@ -491,19 +624,7 @@ static void mark_slice (intnat work)
           /* Subphase_mark_main is done.
              Mark finalised values. */
           CAML_EV_BEGIN(EV_MAJOR_MARK_MAIN);
-          gray_vals_cur = gray_vals_ptr;
           caml_final_update_mark_phase ();
-          gray_vals_ptr = gray_vals_cur;
-          if (gray_vals_ptr > gray_vals){
-            v = *--gray_vals_ptr;
-            CAMLassert (start == 0);
-#ifdef NO_NAKED_POINTERS
-            if (Tag_val(v) == Closure_tag) {
-              start = Start_env_closinfo(Closinfo_val(v));
-              CAMLassert(start <= Wosize_val(v));
-            }
-#endif
-          }
           /* Complete the marking */
           ephes_to_check = ephes_checked_if_pure;
           CAML_EV_END(EV_MAJOR_MARK_MAIN);
@@ -532,9 +653,6 @@ static void mark_slice (intnat work)
       }
     }
   }
-  gray_vals_cur = gray_vals_ptr;
-  current_value = v;
-  current_index = start;
   CAML_EV_COUNTER(EV_C_MAJOR_MARK_SLICE_FIELDS, slice_fields);
   CAML_EV_COUNTER(EV_C_MAJOR_MARK_SLICE_POINTERS, slice_pointers);
 }
@@ -575,14 +693,15 @@ static void sweep_slice (intnat work)
   caml_gc_message (0x40, "Sweeping %"
                    ARCH_INTNAT_PRINTF_FORMAT "d words\n", work);
   while (work > 0){
-    if (caml_gc_sweep_hp < limit){
+    if (caml_gc_sweep_hp < sweep_limit){
       hp = caml_gc_sweep_hp;
       hd = Hd_hp (hp);
       work -= Whsize_hd (hd);
       caml_gc_sweep_hp += Bhsize_hd (hd);
       switch (Color_hd (hd)){
       case Caml_white:
-        caml_gc_sweep_hp = (char *) caml_fl_merge_block (Val_hp (hp), limit);
+        caml_gc_sweep_hp =
+            (char *)caml_fl_merge_block(Val_hp (hp), sweep_limit);
         break;
       case Caml_blue:
         /* Only the blocks of the free-list are blue.  See [freelist.c]. */
@@ -593,18 +712,18 @@ static void sweep_slice (intnat work)
         Hd_hp (hp) = Whitehd_hd (hd);
         break;
       }
-      CAMLassert (caml_gc_sweep_hp <= limit);
+      CAMLassert (caml_gc_sweep_hp <= sweep_limit);
     }else{
-      chunk = Chunk_next (chunk);
-      if (chunk == NULL){
+      sweep_chunk = Chunk_next (sweep_chunk);
+      if (sweep_chunk == NULL){
         /* Sweeping is done. */
         ++ Caml_state->stat_major_collections;
         work = 0;
         caml_gc_phase = Phase_idle;
         caml_request_minor_gc ();
       }else{
-        caml_gc_sweep_hp = chunk;
-        limit = chunk + Chunk_size (chunk);
+        caml_gc_sweep_hp = sweep_chunk;
+        sweep_limit = sweep_chunk + Chunk_size (sweep_chunk);
       }
     }
   }
@@ -848,6 +967,7 @@ void caml_finish_major_cycle (void)
   while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX);
   while (caml_gc_phase == Phase_clean) clean_slice (LONG_MAX);
   CAMLassert (caml_gc_phase == Phase_sweep);
+  CAMLassert (redarken_first_chunk == NULL);
   while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX);
   CAMLassert (caml_gc_phase == Phase_idle);
   Caml_state->stat_major_words += caml_allocated_words;
@@ -906,13 +1026,20 @@ void caml_init_major_heap (asize_t heap_size)
   caml_make_free_blocks ((value *) caml_heap_start,
                          Caml_state->stat_heap_wsz, 1, Caml_white);
   caml_gc_phase = Phase_idle;
-  gray_vals_size = 2048;
-  gray_vals = (value *) caml_stat_alloc_noexc (gray_vals_size * sizeof (value));
-  if (gray_vals == NULL)
-    caml_fatal_error ("not enough memory for the gray cache");
-  gray_vals_cur = gray_vals;
-  gray_vals_end = gray_vals + gray_vals_size;
-  heap_is_pure = 1;
+
+  Caml_state->mark_stack = caml_stat_alloc_noexc(sizeof(struct mark_stack));
+  if (Caml_state->mark_stack == NULL)
+    caml_fatal_error ("not enough memory for the mark stack");
+
+  Caml_state->mark_stack->stack =
+    caml_stat_alloc_noexc(MARK_STACK_INIT_SIZE * sizeof(mark_entry));
+
+  if(Caml_state->mark_stack->stack == NULL)
+    caml_fatal_error("not enough memory for the mark stack");
+
+  Caml_state->mark_stack->count = 0;
+  Caml_state->mark_stack->size = MARK_STACK_INIT_SIZE;
+
   caml_allocated_words = 0;
   caml_extra_heap_resources = 0.0;
   for (i = 0; i < Max_major_window; i++) caml_major_ring[i] = 0.0;
@@ -944,9 +1071,9 @@ void caml_finalise_heap (void)
   /* Finalising all values (by means of forced sweeping) */
   caml_fl_init_merge ();
   caml_gc_phase = Phase_sweep;
-  chunk = caml_heap_start;
-  caml_gc_sweep_hp = chunk;
-  limit = chunk + Chunk_size (chunk);
+  sweep_chunk = caml_heap_start;
+  caml_gc_sweep_hp = sweep_chunk;
+  sweep_limit = sweep_chunk + Chunk_size (sweep_chunk);
   while (caml_gc_phase == Phase_sweep)
     sweep_slice (LONG_MAX);
 }

runtime/memory.c

@@ -262,6 +262,8 @@ char *caml_alloc_for_heap (asize_t request)
     mem = (char *) block + sizeof (heap_chunk_head);
     Chunk_size (mem) = size - sizeof (heap_chunk_head);
     Chunk_block (mem) = block;
+    Chunk_redarken_start(mem) = (value*)(mem + Chunk_size(mem));
+    Chunk_redarken_end(mem) = (value*)mem;
     return mem;
 #else
     return NULL;
@@ -277,6 +279,8 @@ char *caml_alloc_for_heap (asize_t request)
     mem += sizeof (heap_chunk_head);
     Chunk_size (mem) = request;
     Chunk_block (mem) = block;
+    Chunk_redarken_start(mem) = (value*)(mem + Chunk_size(mem));
+    Chunk_redarken_end(mem) = (value*)mem;
     return mem;
   }
 }