[project @ 2001-03-22 03:51:08 by hwloidl]

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

diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c
index f147694..d5e4124 100644 (file)
--- a/ghc/rts/Sanity.c
+++ b/ghc/rts/Sanity.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.22 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: Sanity.c,v 1.27 2001/03/22 03:51:10 hwloidl Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -35,6 +35,8 @@
 #include "RtsUtils.h"
 #include "BlockAlloc.h"
 #include "Sanity.h"
+#include "MBlock.h"
+#include "Storage.h"
 #include "Schedule.h"
 #include "StoragePriv.h"   // for END_OF_STATIC_LIST
 
@@ -217,9 +219,7 @@ checkClosure( StgClosure* p )
 {
     const StgInfoTable *info;
 
-#ifndef INTERPRETER    
     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
-#endif
 
     /* Is it a static closure (i.e. in the data segment)? */
     if (LOOKS_LIKE_STATIC(p)) {
@@ -231,15 +231,6 @@ checkClosure( StgClosure* p )
 
     info = get_itbl(p);
     switch (info->type) {
-    case BCO:
-       {
-           StgBCO* bco = stgCast(StgBCO*,p);
-           nat i;
-           for(i=0; i < bco->n_ptrs; ++i) {
-               ASSERT(LOOKS_LIKE_PTR(bcoConstPtr(bco,i)));
-           }
-           return bco_sizeW(bco);
-       }
 
     case MVAR:
       { 
@@ -289,15 +280,14 @@ checkClosure( StgClosure* p )
     case IND_PERM:
     case IND_OLDGEN:
     case IND_OLDGEN_PERM:
-    case CAF_UNENTERED:
-    case CAF_ENTERED:
-    case CAF_BLACKHOLE:
 #ifdef TICKY_TICKY
-    case SE_CAF_BLACKHOLE:
     case SE_BLACKHOLE:
+    case SE_CAF_BLACKHOLE:
 #endif
     case BLACKHOLE:
+    case CAF_BLACKHOLE:
     case FOREIGN:
+    case BCO:
     case STABLE_NAME:
     case MUT_VAR:
     case CONSTR_INTLIKE:
@@ -397,6 +387,11 @@ checkClosure( StgClosure* p )
       ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 
+#ifdef DIST
+    case REMOTE_REF:
+      return sizeofW(StgFetchMe); 
+#endif //DIST
+      
     case FETCH_ME:
       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
       return sizeofW(StgFetchMe);  // see size used in evacuate()
@@ -499,7 +494,7 @@ checkHeap(bdescr *bd, StgPtr start)
 
        /* skip over slop */
        while (p < bd->free &&
-              (*p == 0 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; } 
+              (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; } 
       }
       bd = bd->link;
       if (bd != NULL) {
@@ -510,12 +505,38 @@ checkHeap(bdescr *bd, StgPtr start)
            xxx);
 }
 
+#if defined(PAR)
 /* 
    Check heap between start and end. Used after unpacking graphs.
 */
 extern void 
 checkHeapChunk(StgPtr start, StgPtr end)
 {
+  extern globalAddr *LAGAlookup(StgClosure *addr);
+  StgPtr p;
+  nat size;
+
+  for (p=start; p<end; p+=size) {
+    ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
+    if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
+       *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
+      /* if it's a FM created during unpack and commoned up, it's not global */
+      ASSERT(LAGAlookup((StgClosure*)p)==NULL);
+      size = sizeofW(StgFetchMe);
+    } else if (get_itbl((StgClosure*)p)->type == IND) {
+      *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
+      size = MIN_UPD_SIZE;
+    } else {
+      size = checkClosure(stgCast(StgClosure*,p));
+      /* This is the smallest size of closure that can live in the heap. */
+      ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+    }
+  }
+}
+#else /* !PAR */
+extern void 
+checkHeapChunk(StgPtr start, StgPtr end)
+{
   StgPtr p;
   nat size;
 
@@ -526,6 +547,7 @@ checkHeapChunk(StgPtr start, StgPtr end)
     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
   }
 }
+#endif
 
 //@cindex checkChain
 extern void
@@ -926,11 +948,9 @@ checkLAGAtable(rtsBool check_closures)
     ASSERT(!gala->preferred || gala == gala0);
     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
     ASSERT(gala->next!=gala); // detect direct loops
-    /*
     if ( check_closures ) {
       checkClosure(stgCast(StgClosure*,gala->la));
     }
-    */
   }
 
   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {