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 48d913c..3df5aef 100644 (file)
--- 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));
     }
 }
 
@@ -137,7 +140,6 @@ checkStackFrame( StgPtr c )
       // small bitmap cases (<= 32 entries)
     case STOP_FRAME:
     case RET_SMALL:
-    case RET_VEC_SMALL:
        size = BITMAP_SIZE(info->i.layout.bitmap);
        checkSmallBitmap((StgPtr)c + 1, 
                         BITMAP_BITS(info->i.layout.bitmap), size);
@@ -153,7 +155,6 @@ checkStackFrame( StgPtr c )
     }
 
     case RET_BIG: // large bitmap (> 32 entries)
-    case RET_VEC_BIG:
        size = GET_LARGE_BITMAP(&info->i)->size;
        checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size);
        return 1 + size;
@@ -164,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:
@@ -203,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);
     
@@ -233,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);
 }
 
 
@@ -243,6 +249,7 @@ checkClosure( StgClosure* p )
 
     ASSERT(LOOKS_LIKE_INFO_PTR(p->header.info));
 
+    p = UNTAG_CLOSURE(p);
     /* Is it a static closure (i.e. in the data segment)? */
     if (!HEAP_ALLOCED(p)) {
        ASSERT(closure_STATIC(p));
@@ -250,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));
@@ -324,7 +338,6 @@ checkClosure( StgClosure* p )
        ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->instrs));
        ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->literals));
        ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->ptrs));
-       ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->itbls));
        return bco_sizeW(bco);
     }
 
@@ -362,9 +375,7 @@ checkClosure( StgClosure* p )
 
     case RET_BCO:
     case RET_SMALL:
-    case RET_VEC_SMALL:
     case RET_BIG:
-    case RET_VEC_BIG:
     case RET_DYN:
     case UPDATE_FRAME:
     case STOP_FRAME:
@@ -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);
+      }
   }
 }
 
@@ -820,7 +831,7 @@ 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));