X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FSanity.c;h=6d80898176e0c5240c57f2c4af7c663550db0a48;hb=524b54cec5d3c20edf65b46bf51fff6c839700ab;hp=d4c3dca9c0508cb771cb0c2482e320535116b1c2;hpb=95ca6bff6fc9918203173b442192d9298ef9757a;p=ghc-hetmet.git

diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c
index d4c3dca..6d80898 100644
--- a/ghc/rts/Sanity.c
+++ b/ghc/rts/Sanity.c
@@ -130,6 +130,9 @@ checkStackFrame( StgPtr c )
 
     case UPDATE_FRAME:
       ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgUpdateFrame*)c)->updatee));
+    case ATOMICALLY_FRAME:
+    case CATCH_RETRY_FRAME:
+    case CATCH_STM_FRAME:
     case CATCH_FRAME:
       // small bitmap cases (<= 32 entries)
     case STOP_FRAME:
@@ -151,8 +154,8 @@ checkStackFrame( StgPtr c )
 
     case RET_BIG: // large bitmap (> 32 entries)
     case RET_VEC_BIG:
-	size = info->i.layout.large_bitmap->size;
-	checkLargeBitmap((StgPtr)c + 1, info->i.layout.large_bitmap, size);
+	size = GET_LARGE_BITMAP(&info->i)->size;
+	checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size);
 	return 1 + size;
 
     case RET_FUN:
@@ -170,7 +173,7 @@ checkStackFrame( StgPtr c )
 	    break;
 	case ARG_GEN_BIG:
 	    checkLargeBitmap((StgPtr)ret_fun->payload,
-			     (StgLargeBitmap *)fun_info->f.bitmap, size);
+			     GET_FUN_LARGE_BITMAP(fun_info), size);
 	    break;
 	default:
 	    checkSmallBitmap((StgPtr)ret_fun->payload,
@@ -182,7 +185,7 @@ checkStackFrame( StgPtr c )
     }
 
     default:
-	barf("checkStackFrame: weird activation record found on stack (%p).",c);
+	barf("checkStackFrame: weird activation record found on stack (%p %d).",c,info->i.type);
     }
 }
 
@@ -273,7 +276,6 @@ checkClosure( StgClosure* p )
     case FOREIGN:
     case STABLE_NAME:
     case MUT_VAR:
-    case MUT_CONS:
     case CONSTR_INTLIKE:
     case CONSTR_CHARLIKE:
     case CONSTR_STATIC:
@@ -317,7 +319,7 @@ checkClosure( StgClosure* p )
 
     case THUNK_SELECTOR:
 	    ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgSelector *)p)->selectee));
-	    return sizeofW(StgHeader) + MIN_UPD_SIZE;
+	    return THUNK_SELECTOR_sizeW();
 
     case IND:
 	{ 
@@ -341,6 +343,9 @@ checkClosure( StgClosure* p )
     case UPDATE_FRAME:
     case STOP_FRAME:
     case CATCH_FRAME:
+    case ATOMICALLY_FRAME:
+    case CATCH_RETRY_FRAME:
+    case CATCH_STM_FRAME:
 	    barf("checkClosure: stack frame");
 
     case AP: /* we can treat this as being the same as a PAP */
@@ -360,7 +365,7 @@ checkClosure( StgClosure* p )
 		break;
 	    case ARG_GEN_BIG:
 		checkLargeBitmap( (StgPtr)pap->payload, 
-				  (StgLargeBitmap *)fun_info->f.bitmap, 
+				  GET_FUN_LARGE_BITMAP(fun_info), 
 				  pap->n_args );
 		break;
 	    case ARG_BCO:
@@ -433,6 +438,44 @@ checkClosure( StgClosure* p )
       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 
 #endif
+
+    case TVAR_WAIT_QUEUE:
+      {
+        StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->next_queue_entry));
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->prev_queue_entry));
+        return sizeofW(StgTVarWaitQueue);
+      }
+
+    case TVAR:
+      {
+        StgTVar *tv = (StgTVar *)p;
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->current_value));
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->first_wait_queue_entry));
+        return sizeofW(StgTVar);
+      }
+
+    case TREC_CHUNK:
+      {
+        nat i;
+        StgTRecChunk *tc = (StgTRecChunk *)p;
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->prev_chunk));
+        for (i = 0; i < tc -> next_entry_idx; i ++) {
+          ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].tvar));
+          ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].expected_value));
+          ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].new_value));
+        }
+        return sizeofW(StgTRecChunk);
+      }
+
+    case TREC_HEADER:
+      {
+        StgTRecHeader *trec = (StgTRecHeader *)p;
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> enclosing_trec));
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> current_chunk));
+        return sizeofW(StgTRecHeader);
+      }
+      
       
     case EVACUATED:
 	    barf("checkClosure: found EVACUATED closure %d",
@@ -608,7 +651,7 @@ checkTSO(StgTSO *tso)
     case BlockedOnRead:
     case BlockedOnWrite:
     case BlockedOnDelay:
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
     case BlockedOnDoProc:
 #endif
       /* isOnBQ(blocked_queue) */
@@ -620,6 +663,9 @@ checkTSO(StgTSO *tso)
     case BlockedOnMVar:
       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
       break;
+    case BlockedOnSTM:
+      ASSERT(tso->block_info.closure == END_TSO_QUEUE);
+      break;
     default:
       /* 
 	 Could check other values of why_blocked but I am more 
@@ -715,41 +761,16 @@ checkGlobalTSOList (rtsBool checkTSOs)
    -------------------------------------------------------------------------- */
 
 void
-checkMutableList( StgMutClosure *p, nat gen )
-{
-    bdescr *bd;
-
-    for (; p != END_MUT_LIST; p = p->mut_link) {
-	bd = Bdescr((P_)p);
-	ASSERT(closure_MUTABLE(p));
-	ASSERT(bd->gen_no == gen);
-	ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
-    }
-}
-
-void
-checkMutOnceList( StgMutClosure *p, nat gen )
+checkMutableList( bdescr *mut_bd, nat gen )
 {
     bdescr *bd;
-    StgInfoTable *info;
-
-    for (; p != END_MUT_LIST; p = p->mut_link) {
-	bd = Bdescr((P_)p);
-	info = get_itbl(p);
+    StgPtr q;
+    StgClosure *p;
 
-	ASSERT(!closure_MUTABLE(p));
-	ASSERT(ip_STATIC(info) || bd->gen_no == gen);
-	ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
-
-	switch (info->type) {
-	case IND_STATIC:
-	case IND_OLDGEN:
-	case IND_OLDGEN_PERM:
-	case MUT_CONS:
-	    break;
-	default:
-	    barf("checkMutOnceList: strange closure %p (%s)", 
-		 p, info_type((StgClosure *)p));
+    for (bd = mut_bd; bd != NULL; bd = bd->link) {
+	for (q = bd->start; q < bd->free; q++) {
+	    p = (StgClosure *)*q;
+	    ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
 	}
     }
 }