X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FSanity.c;h=8f3b627a2bbae3c8505b81ae16de6d1e6625f9e2;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hp=7de8ec7d0a906d1b48c617e2e10e427269b3ceec;hpb=9ff76535edb25ab7434284adddb5c64708ecb547;p=ghc-hetmet.git

diff --git a/rts/Sanity.c b/rts/Sanity.c
index 7de8ec7..8f3b627 100644
--- a/rts/Sanity.c
+++ b/rts/Sanity.c
@@ -80,13 +80,16 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
 static void 
 checkClosureShallow( StgClosure* p )
 {
-    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+    StgClosure *q;
+
+    q = UNTAG_CLOSURE(p);
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
 
     /* Is it a static closure? */
-    if (!HEAP_ALLOCED(p)) {
-	ASSERT(closure_STATIC(p));
+    if (!HEAP_ALLOCED(q)) {
+	ASSERT(closure_STATIC(q));
     } else {
-	ASSERT(!closure_STATIC(p));
+	ASSERT(!closure_STATIC(q));
     }
 }
 
@@ -162,7 +165,7 @@ checkStackFrame( StgPtr c )
 	StgRetFun *ret_fun;
 
 	ret_fun = (StgRetFun *)c;
-	fun_info = get_fun_itbl(ret_fun->fun);
+	fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 	size = ret_fun->size;
 	switch (fun_info->f.fun_type) {
 	case ARG_GEN:
@@ -201,11 +204,13 @@ checkStackChunk( StgPtr sp, StgPtr stack_end )
 }
 
 static void
-checkPAP (StgClosure *fun, StgClosure** payload, StgWord n_args)
+checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args)
 { 
+    StgClosure *fun;
     StgClosure *p;
     StgFunInfoTable *fun_info;
     
+    fun = UNTAG_CLOSURE(tagged_fun);
     ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun));
     fun_info = get_fun_itbl(fun);
     
@@ -231,6 +236,9 @@ checkPAP (StgClosure *fun, StgClosure** payload, StgWord n_args)
 			  n_args );
 	break;
     }
+
+    ASSERT(fun_info->f.arity > TAG_MASK ? GET_CLOSURE_TAG(tagged_fun) == 1
+           : GET_CLOSURE_TAG(tagged_fun) == fun_info->f.arity);
 }
 
 
@@ -239,8 +247,9 @@ checkClosure( StgClosure* p )
 {
     const StgInfoTable *info;
 
-    ASSERT(LOOKS_LIKE_INFO_PTR(p->header.info));
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 
+    p = UNTAG_CLOSURE(p);
     /* Is it a static closure (i.e. in the data segment)? */
     if (!HEAP_ALLOCED(p)) {
 	ASSERT(closure_STATIC(p));
@@ -248,10 +257,17 @@ checkClosure( StgClosure* p )
 	ASSERT(!closure_STATIC(p));
     }
 
-    info = get_itbl(p);
+    info = p->header.info;
+
+    if (IS_FORWARDING_PTR(info)) {
+        barf("checkClosure: found EVACUATED closure %d", info->type);
+    }
+    info = INFO_PTR_TO_STRUCT(info);
+
     switch (info->type) {
 
-    case MVAR:
+    case MVAR_CLEAN:
+    case MVAR_DIRTY:
       { 
 	StgMVar *mvar = (StgMVar *)p;
 	ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
@@ -496,10 +512,6 @@ checkClosure( StgClosure* p )
         return sizeofW(StgTRecHeader);
       }
       
-      
-    case EVACUATED:
-	    barf("checkClosure: found EVACUATED closure %d",
-		 info->type);
     default:
 	    barf("checkClosure (closure type %d)", info->type);
     }
@@ -575,7 +587,7 @@ checkHeap(bdescr *bd)
 	    
 	    /* skip over slop */
 	    while (p < bd->free &&
-		   (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR((void*)*p))) { p++; } 
+		   (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR(*p))) { p++; } 
 	}
     }
 }
@@ -616,7 +628,7 @@ checkHeapChunk(StgPtr start, StgPtr end)
   nat size;
 
   for (p=start; p<end; p+=size) {
-    ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
+    ASSERT(LOOKS_LIKE_INFO_PTR(*p));
     size = checkClosure((StgClosure *)p);
     /* This is the smallest size of closure that can live in the heap. */
     ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
@@ -642,7 +654,7 @@ checkTSO(StgTSO *tso)
     StgPtr stack_end = stack + stack_size;
 
     if (tso->what_next == ThreadRelocated) {
-      checkTSO(tso->link);
+      checkTSO(tso->_link);
       return;
     }
 
@@ -771,13 +783,25 @@ checkThreadQsSanity (rtsBool check_TSO_too)
 void
 checkGlobalTSOList (rtsBool checkTSOs)
 {
-  extern  StgTSO *all_threads;
   StgTSO *tso;
-  for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
-      ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
-      ASSERT(get_itbl(tso)->type == TSO);
-      if (checkTSOs)
-	  checkTSO(tso);
+  nat s;
+
+  for (s = 0; s < total_steps; s++) {
+      for (tso=all_steps[s].threads; tso != END_TSO_QUEUE; 
+           tso = tso->global_link) {
+          ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
+          ASSERT(get_itbl(tso)->type == TSO);
+          if (checkTSOs)
+              checkTSO(tso);
+
+          // If this TSO is dirty and in an old generation, it better
+          // be on the mutable list.
+          if (tso->what_next == ThreadRelocated) continue;
+          if (tso->flags & (TSO_DIRTY|TSO_LINK_DIRTY)) {
+              ASSERT(Bdescr((P_)tso)->gen_no == 0 || tso->flags & TSO_MARKED);
+              tso->flags &= ~TSO_MARKED;
+          }
+      }
   }
 }
 
@@ -796,10 +820,27 @@ checkMutableList( bdescr *mut_bd, nat gen )
 	for (q = bd->start; q < bd->free; q++) {
 	    p = (StgClosure *)*q;
 	    ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
+            if (get_itbl(p)->type == TSO) {
+                ((StgTSO *)p)->flags |= TSO_MARKED;
+            }
 	}
     }
 }
 
+void
+checkMutableLists (void)
+{
+    nat g, i;
+
+    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+        checkMutableList(generations[g].mut_list, g);
+        for (i = 0; i < n_capabilities; i++) {
+            checkMutableList(capabilities[i].mut_lists[g], g);
+        }
+    }
+    checkGlobalTSOList(rtsTrue);
+}
+
 /*
   Check the static objects list.
 */
@@ -815,10 +856,10 @@ checkStaticObjects ( StgClosure* static_objects )
     switch (info->type) {
     case IND_STATIC:
       { 
-	StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
+        StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
 
 	ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
-	ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
+	ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
 	p = *IND_STATIC_LINK((StgClosure *)p);
 	break;
       }