[project @ 2005-10-12 12:57:23 by simonmar]

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

diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c
index 410df74..43200d2 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,9 +278,9 @@ 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 FUN:
@@ -270,7 +304,6 @@ checkClosure( StgClosure* p )
 #endif
     case BLACKHOLE:
     case CAF_BLACKHOLE:
-    case FOREIGN:
     case STABLE_NAME:
     case MUT_VAR:
     case CONSTR_INTLIKE:
@@ -323,12 +356,9 @@ checkClosure( StgClosure* p )
            /* we don't expect to see any of these after GC
             * but they might appear during execution
             */
-           P_ q;
            StgInd *ind = (StgInd *)p;
            ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
-           q = (P_)p + sizeofW(StgInd);
-           while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/
-           return q - (P_)p;
+           return sizeofW(StgHeader) + MIN_UPD_SIZE;
        }
 
     case RET_BCO:
@@ -345,39 +375,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:
     { 
@@ -537,6 +547,12 @@ checkHeap(bdescr *bd)
 {
     StgPtr p;
 
+#if defined(SMP)
+    // heap sanity checking doesn't work with SMP, because we can't
+    // zero the slop (see Updates.h).
+    return;
+#endif
+
     for (; bd != NULL; bd = bd->link) {
        p = bd->start;
        while (p < bd->free) {
@@ -791,20 +807,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:
@@ -873,30 +889,6 @@ checkBQ (StgTSO *bqe, StgClosure *closure)
     }
   } while (!end);
 }
-#else
-void
-checkBQ (StgTSO *bqe, StgClosure *closure) 
-{  
-  rtsBool end = rtsFalse;
-  StgInfoTable *info = get_itbl(closure);
-
-  ASSERT(info->type == MVAR);
-
-  do {
-    switch (get_itbl(bqe)->type) {
-    case TSO:
-      checkClosure((StgClosure *)bqe);
-      bqe = bqe->link;
-      end = (bqe==END_TSO_QUEUE);
-      break;
-
-    default:
-      barf("checkBQ: strange closure %d in blocking queue for closure %p\n", 
-          get_itbl(bqe)->type, closure, info->type);
-    }
-  } while (!end);
-}
-    
 #endif