Fix COMPACT_NFDATA closure size, more CNF sanity checking

We now do a shallow closure check on objects in compact regions.

See the new comment on why we can't do a "normal" closure check.

2 files changed, 30 insertions, 20 deletions

diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index b58cdc3874..03ea91fcb6 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -695,11 +695,11 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE
    compaction is in progress and the hash table needs to be scanned by the GC.
    ------------------------------------------------------------------------- */
 
-INFO_TABLE( stg_COMPACT_NFDATA_CLEAN, 0, 5, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA")
+INFO_TABLE( stg_COMPACT_NFDATA_CLEAN, 0, 8, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA")
     ()
 { foreign "C" barf("COMPACT_NFDATA_CLEAN object (%p) entered!", R1) never returns; }
 
-INFO_TABLE( stg_COMPACT_NFDATA_DIRTY, 0, 5, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA")
+INFO_TABLE( stg_COMPACT_NFDATA_DIRTY, 0, 8, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA")
     ()
 { foreign "C" barf("COMPACT_NFDATA_DIRTY object (%p) entered!", R1) never returns; }
 
diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c
index ff76f747c9..3585bd93b4 100644
--- a/rts/sm/Sanity.c
+++ b/rts/sm/Sanity.c
@@ -79,14 +79,10 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, uint32_t size )
  * used to avoid recursion between checking PAPs and checking stack
  * chunks.
  */
-
 static void
 checkClosureShallow( const StgClosure* p )
 {
-    const StgClosure *q;
-
-    q = UNTAG_CONST_CLOSURE(p);
-    ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(UNTAG_CONST_CLOSURE(p)));
 }
 
 // check an individual stack object
@@ -223,6 +219,7 @@ checkClosureProfSanity(const StgClosure *p)
 }
 #endif
 
+// Returns closure size in words
 StgOffset
 checkClosure( const StgClosure* p )
 {
@@ -464,11 +461,9 @@ checkClosure( const StgClosure* p )
 
 void checkHeapChain (bdescr *bd)
 {
-    StgPtr p;
-
     for (; bd != NULL; bd = bd->link) {
         if(!(bd->flags & BF_SWEPT)) {
-            p = bd->start;
+            StgPtr p = bd->start;
             while (p < bd->free) {
                 uint32_t size = checkClosure((StgClosure *)p);
                 /* This is the smallest size of closure that can live in the heap */
@@ -511,27 +506,42 @@ checkLargeObjects(bdescr *bd)
 static void
 checkCompactObjects(bdescr *bd)
 {
-    // Compact objects are similar to large objects,
-    // but they have a StgCompactNFDataBlock at the beginning,
-    // before the actual closure
+    // Compact objects are similar to large objects, but they have a
+    // StgCompactNFDataBlock at the beginning, before the actual closure
 
     for ( ; bd != NULL; bd = bd->link) {
-        StgCompactNFDataBlock *block, *last;
-        StgCompactNFData *str;
-        StgWord totalW;
-
         ASSERT(bd->flags & BF_COMPACT);
 
-        block = (StgCompactNFDataBlock*)bd->start;
-        str = block->owner;
+        StgCompactNFDataBlock *block = (StgCompactNFDataBlock*)bd->start;
+        StgCompactNFData *str = block->owner;
         ASSERT((W_)str == (W_)block + sizeof(StgCompactNFDataBlock));
 
-        totalW = 0;
+        StgWord totalW = 0;
+        StgCompactNFDataBlock *last;
         for ( ; block ; block = block->next) {
             last = block;
             ASSERT(block->owner == str);
 
             totalW += Bdescr((P_)block)->blocks * BLOCK_SIZE_W;
+
+            StgPtr start = Bdescr((P_)block)->start + sizeofW(StgCompactNFDataBlock);
+            StgPtr free;
+            if (Bdescr((P_)block)->start == (P_)str->nursery) {
+                free = str->hp;
+            } else {
+                free = Bdescr((P_)block)->free;
+            }
+            StgPtr p = start;
+            while (p < free)  {
+                // We can't use checkClosure() here because in
+                // compactAdd#/compactAddWithSharing# when we see a non-
+                // compactable object (a function, mutable object, or pinned
+                // object) we leave the location for the object in the payload
+                // empty.
+                StgClosure *c = (StgClosure*)p;
+                checkClosureShallow(c);
+                p += closure_sizeW(c);
+            }
         }
 
         ASSERT(str->totalW == totalW);