Fix #650: use a card table to mark dirty sections of mutable arrays

The card table is an array of bytes, placed directly following the
actual array data.  This means that array reading is unaffected, but
array writing needs to read the array size from the header in order to
find the card table.

We use a bytemap rather than a bitmap, because updating the card table
must be multi-thread safe.  Each byte refers to 128 entries of the
array, but this is tunable by changing the constant
MUT_ARR_PTRS_CARD_BITS in includes/Constants.h.

3 files changed, 155 insertions, 61 deletions

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 377418af41..c146454ab1 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -132,18 +132,23 @@ stg_newAlignedPinnedByteArrayzh
 
 stg_newArrayzh
 {
-    W_ words, n, init, arr, p;
+    W_ words, n, init, arr, p, size;
     /* Args: R1 = words, R2 = initialisation value */
 
     n = R1;
     MAYBE_GC(R2_PTR,stg_newArrayzh);
 
-    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + n;
+    // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
+    // in the array, making sure we round up, and then rounding up to a whole
+    // number of words.
+    size = n + mutArrPtrsCardWords(n);
+    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;
     ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr",words) [R2];
     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
 
     SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
     StgMutArrPtrs_ptrs(arr) = n;
+    StgMutArrPtrs_size(arr) = size;
 
     // Initialise all elements of the the array with the value in R2
     init = R2;
@@ -154,6 +159,13 @@ stg_newArrayzh
 	p = p + WDS(1);
 	goto for;
     }
+    // Initialise the mark bits with 0
+  for2:
+    if (p < arr + WDS(size)) {
+	W_[p] = 0;
+	p = p + WDS(1);
+	goto for2;
+    }
 
     RET_P(arr);
 }
@@ -165,7 +177,7 @@ stg_unsafeThawArrayzh
   // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN 
   // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
   // it on the mutable list for the GC to remove (removing something from
-  // the mutable list is not easy, because the mut_list is only singly-linked).
+  // the mutable list is not easy).
   // 
   // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
   // when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0
@@ -1582,9 +1594,10 @@ stg_unpackClosurezh
     }}
 out:
 
-    W_ ptrs_arr_sz, nptrs_arr_sz;
+    W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
     nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
-    ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs);
+    ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
+    ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
 
     ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, stg_unpackClosurezh);
 
@@ -1596,6 +1609,8 @@ out:
 
     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
+    StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
+
     p = 0;
 for:
     if(p < ptrs) {
@@ -1603,6 +1618,9 @@ for:
 	 p = p + 1;
 	 goto for;
     }
+    /* We can leave the card table uninitialised, since the array is
+       allocated in the nursery.  The GC will fill it in if/when the array
+       is promoted. */
     
     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
     StgArrWords_words(nptrs_arr) = nptrs;
diff --git a/rts/Weak.c b/rts/Weak.c
index f5e918a921..94bead3752 100644
--- a/rts/Weak.c
+++ b/rts/Weak.c
@@ -76,7 +76,8 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
     StgWeak *w;
     StgTSO *t;
     StgMutArrPtrs *arr;
-    nat n;
+    StgWord size;
+    nat n, i;
 
     running_finalizers = rtsTrue;
 
@@ -120,10 +121,12 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
 
     debugTrace(DEBUG_weak, "weak: batching %d finalizers", n);
 
-    arr = (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + n);
+    size = n + mutArrPtrsCardTableSize(n);
+    arr = (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
     SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_info, CCS_SYSTEM);
     arr->ptrs = n;
+    arr->size = size;
 
     n = 0;
     for (w = list; w; w = w->link) {
@@ -132,6 +135,10 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
 	    n++;
 	}
     }
+    // set all the cards to 1
+    for (i = n; i < size; i++) {
+        arr->payload[i] = (StgClosure *)(W_)(-1);
+    }
 
     t = createIOThread(cap, 
 		       RtsFlags.GcFlags.initialStkSize, 
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index 4fa0a220e0..e9127acd70 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -112,6 +112,81 @@ scavengeTSO (StgTSO *tso)
 }
 
 /* -----------------------------------------------------------------------------
+   Mutable arrays of pointers
+   -------------------------------------------------------------------------- */
+
+static StgPtr scavenge_mut_arr_ptrs (StgMutArrPtrs *a)
+{
+    lnat m;
+    rtsBool any_failed;
+    StgPtr p, q;
+
+    any_failed = rtsFalse;
+    p = (StgPtr)&a->payload[0];
+    for (m = 0; (int)m < (int)mutArrPtrsCards(a->ptrs) - 1; m++)
+    {
+        q = p + (1 << MUT_ARR_PTRS_CARD_BITS);
+        for (; p < q; p++) {
+            evacuate((StgClosure**)p);
+        }
+        if (gct->failed_to_evac) {
+            any_failed = rtsTrue;
+            *mutArrPtrsCard(a,m) = 1;
+            gct->failed_to_evac = rtsFalse;
+        } else {
+            *mutArrPtrsCard(a,m) = 0;
+        }
+    }
+
+    q = (StgPtr)&a->payload[a->ptrs];
+    if (p < q) {
+        for (; p < q; p++) {
+            evacuate((StgClosure**)p);
+        }
+        if (gct->failed_to_evac) {
+            any_failed = rtsTrue;
+            *mutArrPtrsCard(a,m) = 1;
+            gct->failed_to_evac = rtsFalse;
+        } else {
+            *mutArrPtrsCard(a,m) = 0;
+        }
+    }
+
+    gct->failed_to_evac = any_failed;
+    return (StgPtr)a + mut_arr_ptrs_sizeW(a);
+}
+    
+// scavenge only the marked areas of a MUT_ARR_PTRS
+static StgPtr scavenge_mut_arr_ptrs_marked (StgMutArrPtrs *a)
+{
+    lnat m;
+    StgPtr p, q;
+    rtsBool any_failed;
+
+    any_failed = rtsFalse;
+    for (m = 0; m < mutArrPtrsCards(a->ptrs); m++)
+    {
+        if (*mutArrPtrsCard(a,m) != 0) {
+            p = (StgPtr)&a->payload[m << MUT_ARR_PTRS_CARD_BITS];
+            q = stg_min(p + (1 << MUT_ARR_PTRS_CARD_BITS),
+                        (StgPtr)&a->payload[a->ptrs]);
+            for (; p < q; p++) {
+                evacuate((StgClosure**)p);
+            }
+            if (gct->failed_to_evac) {
+                any_failed = rtsTrue;
+                gct->failed_to_evac = rtsFalse;
+            } else {
+                *mutArrPtrsCard(a,m) = 0;
+            }
+        }
+    }
+
+    gct->failed_to_evac = any_failed;
+    return (StgPtr)a + mut_arr_ptrs_sizeW(a);
+}
+
+/* -----------------------------------------------------------------------------
    Blocks of function args occur on the stack (at the top) and
    in PAPs.
    -------------------------------------------------------------------------- */
@@ -554,20 +629,14 @@ scavenge_block (bdescr *bd)
 
     case MUT_ARR_PTRS_CLEAN:
     case MUT_ARR_PTRS_DIRTY:
-	// follow everything 
     {
-	StgPtr next;
+        // We don't eagerly promote objects pointed to by a mutable
+        // array, but if we find the array only points to objects in
+        // the same or an older generation, we mark it "clean" and
+        // avoid traversing it during minor GCs.
+        gct->eager_promotion = rtsFalse;
 
-	// We don't eagerly promote objects pointed to by a mutable
-	// array, but if we find the array only points to objects in
-	// the same or an older generation, we mark it "clean" and
-	// avoid traversing it during minor GCs.
-	gct->eager_promotion = rtsFalse;
-	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-	    evacuate((StgClosure **)p);
-	}
-	gct->eager_promotion = saved_eager_promotion;
+        p = scavenge_mut_arr_ptrs((StgMutArrPtrs*)p);
 
 	if (gct->failed_to_evac) {
 	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
@@ -575,6 +644,7 @@ scavenge_block (bdescr *bd)
 	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
 	}
 
+	gct->eager_promotion = saved_eager_promotion;
 	gct->failed_to_evac = rtsTrue; // always put it on the mutable list.
 	break;
     }
@@ -583,17 +653,12 @@ scavenge_block (bdescr *bd)
     case MUT_ARR_PTRS_FROZEN0:
 	// follow everything 
     {
-	StgPtr next;
-
-	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-	    evacuate((StgClosure **)p);
-	}
+        p = scavenge_mut_arr_ptrs((StgMutArrPtrs*)p);
 
 	// If we're going to put this object on the mutable list, then
 	// set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
 	if (gct->failed_to_evac) {
-	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
+            ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
 	} else {
 	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
 	}
@@ -922,7 +987,6 @@ scavenge_mark_stack(void)
 	case MUT_ARR_PTRS_DIRTY:
 	    // follow everything 
 	{
-	    StgPtr next;
 	    rtsBool saved_eager;
 
 	    // We don't eagerly promote objects pointed to by a mutable
@@ -931,18 +995,16 @@ scavenge_mark_stack(void)
 	    // avoid traversing it during minor GCs.
 	    saved_eager = gct->eager_promotion;
 	    gct->eager_promotion = rtsFalse;
-	    next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	    for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-		evacuate((StgClosure **)p);
-	    }
-	    gct->eager_promotion = saved_eager;
 
-	    if (gct->failed_to_evac) {
-		((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
-	    } else {
-		((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
-	    }
+            scavenge_mut_arr_ptrs((StgMutArrPtrs *)p);
+
+            if (gct->failed_to_evac) {
+                ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
+            } else {
+                ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
+            }
 
+	    gct->eager_promotion = saved_eager;
 	    gct->failed_to_evac = rtsTrue; // mutable anyhow.
 	    break;
 	}
@@ -951,12 +1013,9 @@ scavenge_mark_stack(void)
 	case MUT_ARR_PTRS_FROZEN0:
 	    // follow everything 
 	{
-	    StgPtr next, q = p;
+	    StgPtr q = p;
 	    
-	    next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	    for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-		evacuate((StgClosure **)p);
-	    }
+            scavenge_mut_arr_ptrs((StgMutArrPtrs *)p);
 
 	    // If we're going to put this object on the mutable list, then
 	    // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
@@ -1196,7 +1255,6 @@ scavenge_one(StgPtr p)
     case MUT_ARR_PTRS_CLEAN:
     case MUT_ARR_PTRS_DIRTY:
     {
-	StgPtr next, q;
 	rtsBool saved_eager;
 
 	// We don't eagerly promote objects pointed to by a mutable
@@ -1205,19 +1263,16 @@ scavenge_one(StgPtr p)
 	// avoid traversing it during minor GCs.
 	saved_eager = gct->eager_promotion;
 	gct->eager_promotion = rtsFalse;
-	q = p;
-	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-	    evacuate((StgClosure **)p);
-	}
-	gct->eager_promotion = saved_eager;
+
+        scavenge_mut_arr_ptrs((StgMutArrPtrs *)p);
 
 	if (gct->failed_to_evac) {
-	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
+	    ((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
 	} else {
-	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
+	    ((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
 	}
 
+	gct->eager_promotion = saved_eager;
 	gct->failed_to_evac = rtsTrue;
 	break;
     }
@@ -1226,19 +1281,14 @@ scavenge_one(StgPtr p)
     case MUT_ARR_PTRS_FROZEN0:
     {
 	// follow everything 
-	StgPtr next, q=p;
-      
-	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-	    evacuate((StgClosure **)p);
-	}
-
+        scavenge_mut_arr_ptrs((StgMutArrPtrs *)p);
+        
 	// If we're going to put this object on the mutable list, then
 	// set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
 	if (gct->failed_to_evac) {
-	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
+	    ((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
 	} else {
-	    ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
+	    ((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
 	}
 	break;
     }
@@ -1412,13 +1462,32 @@ scavenge_mutable_list(bdescr *bd, generation *gen)
 	    // definitely doesn't point into a young generation.
 	    // Clean objects don't need to be scavenged.  Some clean
 	    // objects (MUT_VAR_CLEAN) are not kept on the mutable
-	    // list at all; others, such as MUT_ARR_PTRS_CLEAN
+	    // list at all; others, such as TSO
 	    // are always on the mutable list.
 	    //
 	    switch (get_itbl((StgClosure *)p)->type) {
 	    case MUT_ARR_PTRS_CLEAN:
 		recordMutableGen_GC((StgClosure *)p,gen->no);
 		continue;
+	    case MUT_ARR_PTRS_DIRTY:
+            {
+                rtsBool saved_eager;
+                saved_eager = gct->eager_promotion;
+                gct->eager_promotion = rtsFalse;
+
+                scavenge_mut_arr_ptrs_marked((StgMutArrPtrs *)p);
+
+                if (gct->failed_to_evac) {
+                    ((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
+                } else {
+                    ((StgClosure *)p)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
+                }
+
+                gct->eager_promotion = saved_eager;
+                gct->failed_to_evac = rtsFalse;
+		recordMutableGen_GC((StgClosure *)p,gen->no);
+		continue;
+            }
 	    case TSO: {
 		StgTSO *tso = (StgTSO *)p;
 		if (tso->dirty == 0) {