[project @ 2005-05-05 13:17:47 by simonmar]

[ghc-hetmet.git] / ghc / rts / Sanity.c

diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c
index 7bc2f83..89c1a7e 100644 (file)
--- a/ghc/rts/Sanity.c
+++ b/ghc/rts/Sanity.c
@@ -202,6 +202,40 @@ checkStackChunk( StgPtr sp, StgPtr stack_end )
     // ASSERT( p == stack_end ); -- HWL
 }
 
+static void
+checkPAP (StgClosure *fun, StgClosure** payload, StgWord n_args)
+{ 
+    StgClosure *p;
+    StgFunInfoTable *fun_info;
+    
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun));
+    fun_info = get_fun_itbl(fun);
+    
+    p = (StgClosure *)payload;
+    switch (fun_info->f.fun_type) {
+    case ARG_GEN:
+       checkSmallBitmap( (StgPtr)payload, 
+                         BITMAP_BITS(fun_info->f.b.bitmap), n_args );
+       break;
+    case ARG_GEN_BIG:
+       checkLargeBitmap( (StgPtr)payload, 
+                         GET_FUN_LARGE_BITMAP(fun_info), 
+                         n_args );
+       break;
+    case ARG_BCO:
+       checkLargeBitmap( (StgPtr)payload, 
+                         BCO_BITMAP(fun), 
+                         n_args );
+       break;
+    default:
+       checkSmallBitmap( (StgPtr)payload, 
+                         BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
+                         n_args );
+       break;
+    }
+}
+
+
 StgOffset 
 checkClosure( StgClosure* p )
 {
@@ -244,14 +278,11 @@ checkClosure( StgClosure* p )
       {
        nat i;
        for (i = 0; i < info->layout.payload.ptrs; i++) {
-         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
+         ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i]));
        }
-       return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
+       return stg_max(thunk_sizeW_fromITBL(info), sizeofW(StgHeader)+MIN_UPD_SIZE);
       }
 
-    case BLACKHOLE_BQ:
-      checkBQ(((StgBlockingQueue *)p)->blocking_queue, p);
-      /* fall through to basic ptr check */
     case FUN:
     case FUN_1_0:
     case FUN_0_1:
@@ -348,39 +379,19 @@ checkClosure( StgClosure* p )
     case CATCH_STM_FRAME:
            barf("checkClosure: stack frame");
 
-    case AP: /* we can treat this as being the same as a PAP */
+    case AP:
+    {
+       StgAP* ap = (StgAP *)p;
+       checkPAP (ap->fun, ap->payload, ap->n_args);
+       return ap_sizeW(ap);
+    }
+
     case PAP:
-       { 
-           StgFunInfoTable *fun_info;
-           StgPAP* pap = (StgPAP *)p;
-
-           ASSERT(LOOKS_LIKE_CLOSURE_PTR(pap->fun));
-           fun_info = get_fun_itbl(pap->fun);
-
-           p = (StgClosure *)pap->payload;
-           switch (fun_info->f.fun_type) {
-           case ARG_GEN:
-               checkSmallBitmap( (StgPtr)pap->payload, 
-                                 BITMAP_BITS(fun_info->f.b.bitmap), pap->n_args );
-               break;
-           case ARG_GEN_BIG:
-               checkLargeBitmap( (StgPtr)pap->payload, 
-                                 GET_FUN_LARGE_BITMAP(fun_info), 
-                                 pap->n_args );
-               break;
-           case ARG_BCO:
-               checkLargeBitmap( (StgPtr)pap->payload, 
-                                 BCO_BITMAP(pap->fun), 
-                                 pap->n_args );
-               break;
-           default:
-               checkSmallBitmap( (StgPtr)pap->payload, 
-                                 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
-                                 pap->n_args );
-               break;
-           }
-           return pap_sizeW(pap);
-       }
+    {
+       StgPAP* pap = (StgPAP *)p;
+       checkPAP (pap->fun, pap->payload, pap->n_args);
+       return pap_sizeW(pap);
+    }
 
     case AP_STACK:
     { 
@@ -395,6 +406,7 @@ checkClosure( StgClosure* p )
 
     case MUT_ARR_PTRS:
     case MUT_ARR_PTRS_FROZEN:
+    case MUT_ARR_PTRS_FROZEN0:
        {
            StgMutArrPtrs* a = (StgMutArrPtrs *)p;
            nat i;
@@ -644,8 +656,7 @@ checkTSO(StgTSO *tso)
       break;
     case BlockedOnBlackHole: 
       checkClosureShallow(tso->block_info.closure);
-      ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
-            get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
+      ASSERT(get_itbl(tso->block_info.closure)->type==BLACKHOLE ||
              get_itbl(tso->block_info.closure)->type==RBH);
       break;
     case BlockedOnRead:
@@ -794,20 +805,20 @@ checkStaticObjects ( StgClosure* static_objects )
 
        ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
        ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
-       p = IND_STATIC_LINK((StgClosure *)p);
+       p = *IND_STATIC_LINK((StgClosure *)p);
        break;
       }
 
     case THUNK_STATIC:
-      p = THUNK_STATIC_LINK((StgClosure *)p);
+      p = *THUNK_STATIC_LINK((StgClosure *)p);
       break;
 
     case FUN_STATIC:
-      p = FUN_STATIC_LINK((StgClosure *)p);
+      p = *FUN_STATIC_LINK((StgClosure *)p);
       break;
 
     case CONSTR_STATIC:
-      p = STATIC_LINK(info,(StgClosure *)p);
+      p = *STATIC_LINK(info,(StgClosure *)p);
       break;
 
     default:
@@ -830,8 +841,7 @@ checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
   rtsBool end = rtsFalse;
   StgInfoTable *info = get_itbl(closure);
 
-  ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
-        || info->type == FETCH_ME_BQ || info->type == RBH);
+  ASSERT(info->type == MVAR || info->type == FETCH_ME_BQ || info->type == RBH);
 
   do {
     switch (get_itbl(bqe)->type) {
@@ -860,7 +870,7 @@ checkBQ (StgTSO *bqe, StgClosure *closure)
   rtsBool end = rtsFalse;
   StgInfoTable *info = get_itbl(closure);
 
-  ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
+  ASSERT(info->type == MVAR);
 
   do {
     switch (get_itbl(bqe)->type) {
@@ -884,7 +894,7 @@ checkBQ (StgTSO *bqe, StgClosure *closure)
   rtsBool end = rtsFalse;
   StgInfoTable *info = get_itbl(closure);
 
-  ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
+  ASSERT(info->type == MVAR);
 
   do {
     switch (get_itbl(bqe)->type) {