Mostly fix Trac #2431: make empty case acceptable to (most of) GHC

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

diff --git a/rts/Sanity.c b/rts/Sanity.c
index a2ddff8..3df5aef 100644 (file)
--- a/rts/Sanity.c
+++ b/rts/Sanity.c
@@ -204,12 +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(fun);
+    fun = UNTAG_CLOSURE(tagged_fun);
     ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun));
     fun_info = get_fun_itbl(fun);
     
@@ -235,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);
 }
 
 
@@ -253,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));
@@ -501,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);
     }
@@ -647,7 +654,7 @@ checkTSO(StgTSO *tso)
     StgPtr stack_end = stack + stack_size;
 
     if (tso->what_next == ThreadRelocated) {
-      checkTSO(tso->link);
+      checkTSO(tso->_link);
       return;
     }
 
@@ -776,13 +783,17 @@ 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);
+      }
   }
 }