ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.27 2001/03/22 03:51:10 hwloidl Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Sanity checking code for the heap and stack.
   7  *
   8  * Used when debugging: check that the stack looks reasonable.
   9  *
  10  *    - All things that are supposed to be pointers look like pointers.
  11  *
  12  *    - Objects in text space are marked as static closures, those
  13  *      in the heap are dynamic.
  14  *
  15  * ---------------------------------------------------------------------------*/
  16
  17 //@menu
  18 //* Includes::
  19 //* Macros::
  20 //* Stack sanity::
  21 //* Heap Sanity::
  22 //* TSO Sanity::
  23 //* Thread Queue Sanity::
  24 //* Blackhole Sanity::
  25 //@end menu
  26
  27 //@node Includes, Macros
  28 //@subsection Includes
  29
  30 #include "Rts.h"
  31
  32 #ifdef DEBUG                                                   /* whole file */
  33
  34 #include "RtsFlags.h"
  35 #include "RtsUtils.h"
  36 #include "BlockAlloc.h"
  37 #include "Sanity.h"
  38 #include "MBlock.h"
  39 #include "Storage.h"
  40 #include "Schedule.h"
  41 #include "StoragePriv.h"   // for END_OF_STATIC_LIST
  42
  43 //@node Macros, Stack sanity, Includes
  44 //@subsection Macros
  45
  46 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
  47                             ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
  48                              ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
  49
  50 //@node Stack sanity, Heap Sanity, Macros
  51 //@subsection Stack sanity
  52
  53 /* -----------------------------------------------------------------------------
  54    Check stack sanity
  55    -------------------------------------------------------------------------- */
  56
  57 StgOffset checkStackClosure( StgClosure* c );
  58
  59 StgOffset checkStackObject( StgPtr sp );
  60
  61 void      checkStackChunk( StgPtr sp, StgPtr stack_end );
  62
  63 static StgOffset checkSmallBitmap(  StgPtr payload, StgWord32 bitmap );
  64
  65 static StgOffset checkLargeBitmap( StgPtr payload,
  66                                    StgLargeBitmap* large_bitmap );
  67
  68 void checkClosureShallow( StgClosure* p );
  69
  70 //@cindex checkSmallBitmap
  71 static StgOffset
  72 checkSmallBitmap( StgPtr payload, StgWord32 bitmap )
  73 {
  74     StgOffset i;
  75
  76     i = 0;
  77     for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  78         if ((bitmap & 1) == 0) {
  79             checkClosure(stgCast(StgClosure*,payload[i]));
  80         }
  81     }
  82     return i;
  83 }
  84
  85 //@cindex checkLargeBitmap
  86 static StgOffset
  87 checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap )
  88 {
  89     StgWord32 bmp;
  90     StgOffset i;
  91
  92     i = 0;
  93     for (bmp=0; bmp<large_bitmap->size; bmp++) {
  94         StgWord32 bitmap = large_bitmap->bitmap[bmp];
  95         for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  96             if ((bitmap & 1) == 0) {
  97                 checkClosure(stgCast(StgClosure*,payload[i]));
  98             }
  99         }
 100     }
 101     return i;
 102 }
 103
 104 //@cindex checkStackClosure
 105 StgOffset
 106 checkStackClosure( StgClosure* c )
 107 {
 108     const StgInfoTable* info = get_itbl(c);
 109
 110     /* All activation records have 'bitmap' style layout info. */
 111     switch (info->type) {
 112     case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
 113         {
 114             StgRetDyn* r = (StgRetDyn *)c;
 115             return sizeofW(StgRetDyn) +
 116                    checkSmallBitmap(r->payload,r->liveness);
 117         }
 118     case RET_BCO: /* small bitmap (<= 32 entries) */
 119     case RET_SMALL:
 120     case RET_VEC_SMALL:
 121             return 1 + checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap);
 122
 123     case UPDATE_FRAME:
 124       ASSERT(LOOKS_LIKE_PTR(((StgUpdateFrame*)c)->updatee));
 125     case CATCH_FRAME:
 126     case SEQ_FRAME:
 127       /* check that the link field points to another stack frame */
 128       ASSERT(get_itbl(((StgFrame*)c)->link)->type == UPDATE_FRAME ||
 129              get_itbl(((StgFrame*)c)->link)->type == CATCH_FRAME ||
 130              get_itbl(((StgFrame*)c)->link)->type == STOP_FRAME ||
 131              get_itbl(((StgFrame*)c)->link)->type == SEQ_FRAME);
 132       /* fall through */
 133     case STOP_FRAME:
 134 #if defined(GRAN)
 135             return 2 +
 136 #else
 137             return 1 +
 138 #endif
 139                        checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap);
 140     case RET_BIG: /* large bitmap (> 32 entries) */
 141     case RET_VEC_BIG:
 142             return 1 + checkLargeBitmap((StgPtr)c + 1,info->layout.large_bitmap);
 143     case FUN:
 144     case FUN_STATIC: /* probably a slow-entry point return address: */
 145 #if 0 && defined(GRAN)
 146             return 2;
 147 #else
 148             return 1;
 149 #endif
 150     default:
 151             /* if none of the above, maybe it's a closure which looks a
 152              * little like an infotable
 153              */
 154             checkClosureShallow(*(StgClosure **)c);
 155             return 1;
 156             /* barf("checkStackClosure: weird activation record found on stack (%p).",c); */
 157     }
 158 }
 159
 160 /*
 161  * check that it looks like a valid closure - without checking its payload
 162  * used to avoid recursion between checking PAPs and checking stack
 163  * chunks.
 164  */
 165
 166 //@cindex checkClosureShallow
 167 void
 168 checkClosureShallow( StgClosure* p )
 169 {
 170     ASSERT(p);
 171     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info)
 172            || IS_HUGS_CONSTR_INFO(GET_INFO(p)));
 173
 174     /* Is it a static closure (i.e. in the data segment)? */
 175     if (LOOKS_LIKE_STATIC(p)) {
 176         ASSERT(closure_STATIC(p));
 177     } else {
 178         ASSERT(!closure_STATIC(p));
 179         ASSERT(LOOKS_LIKE_PTR(p));
 180     }
 181 }
 182
 183 /* check an individual stack object */
 184 //@cindex checkStackObject
 185 StgOffset
 186 checkStackObject( StgPtr sp )
 187 {
 188     if (IS_ARG_TAG(*sp)) {
 189         /* Tagged words might be "stubbed" pointers, so there's no
 190          * point checking to see whether they look like pointers or
 191          * not (some of them will).
 192          */
 193         return ARG_SIZE(*sp) + 1;
 194     } else if (LOOKS_LIKE_GHC_INFO(*stgCast(StgPtr*,sp))) {
 195         return checkStackClosure(stgCast(StgClosure*,sp));
 196     } else { /* must be an untagged closure pointer in the stack */
 197         checkClosureShallow(*stgCast(StgClosure**,sp));
 198         return 1;
 199     }
 200 }
 201
 202 /* check sections of stack between update frames */
 203 //@cindex checkStackChunk
 204 void
 205 checkStackChunk( StgPtr sp, StgPtr stack_end )
 206 {
 207     StgPtr p;
 208
 209     p = sp;
 210     while (p < stack_end) {
 211         p += checkStackObject( p );
 212     }
 213     // ASSERT( p == stack_end ); -- HWL
 214 }
 215
 216 //@cindex checkStackChunk
 217 StgOffset
 218 checkClosure( StgClosure* p )
 219 {
 220     const StgInfoTable *info;
 221
 222     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
 223
 224     /* Is it a static closure (i.e. in the data segment)? */
 225     if (LOOKS_LIKE_STATIC(p)) {
 226         ASSERT(closure_STATIC(p));
 227     } else {
 228         ASSERT(!closure_STATIC(p));
 229         ASSERT(LOOKS_LIKE_PTR(p));
 230     }
 231
 232     info = get_itbl(p);
 233     switch (info->type) {
 234
 235     case MVAR:
 236       {
 237         StgMVar *mvar = (StgMVar *)p;
 238         ASSERT(LOOKS_LIKE_PTR(mvar->head));
 239         ASSERT(LOOKS_LIKE_PTR(mvar->tail));
 240         ASSERT(LOOKS_LIKE_PTR(mvar->value));
 241 #if 0
 242 #if defined(PAR)
 243         checkBQ((StgBlockingQueueElement *)mvar->head, p);
 244 #else
 245         checkBQ(mvar->head, p);
 246 #endif
 247 #endif
 248         return sizeofW(StgMVar);
 249       }
 250
 251     case THUNK:
 252     case THUNK_1_0:
 253     case THUNK_0_1:
 254     case THUNK_1_1:
 255     case THUNK_0_2:
 256     case THUNK_2_0:
 257       {
 258         nat i;
 259         for (i = 0; i < info->layout.payload.ptrs; i++) {
 260           ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 261         }
 262         return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
 263       }
 264
 265     case BLACKHOLE_BQ:
 266       checkBQ(((StgBlockingQueue *)p)->blocking_queue, p);
 267       /* fall through to basic ptr check */
 268     case FUN:
 269     case FUN_1_0:
 270     case FUN_0_1:
 271     case FUN_1_1:
 272     case FUN_0_2:
 273     case FUN_2_0:
 274     case CONSTR:
 275     case CONSTR_1_0:
 276     case CONSTR_0_1:
 277     case CONSTR_1_1:
 278     case CONSTR_0_2:
 279     case CONSTR_2_0:
 280     case IND_PERM:
 281     case IND_OLDGEN:
 282     case IND_OLDGEN_PERM:
 283 #ifdef TICKY_TICKY
 284     case SE_BLACKHOLE:
 285     case SE_CAF_BLACKHOLE:
 286 #endif
 287     case BLACKHOLE:
 288     case CAF_BLACKHOLE:
 289     case FOREIGN:
 290     case BCO:
 291     case STABLE_NAME:
 292     case MUT_VAR:
 293     case CONSTR_INTLIKE:
 294     case CONSTR_CHARLIKE:
 295     case CONSTR_STATIC:
 296     case CONSTR_NOCAF_STATIC:
 297     case THUNK_STATIC:
 298     case FUN_STATIC:
 299         {
 300             nat i;
 301             for (i = 0; i < info->layout.payload.ptrs; i++) {
 302                 ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 303             }
 304             return sizeW_fromITBL(info);
 305         }
 306
 307     case IND_STATIC: /* (1, 0) closure */
 308       ASSERT(LOOKS_LIKE_PTR(((StgIndStatic*)p)->indirectee));
 309       return sizeW_fromITBL(info);
 310
 311     case WEAK:
 312       /* deal with these specially - the info table isn't
 313        * representative of the actual layout.
 314        */
 315       { StgWeak *w = (StgWeak *)p;
 316         ASSERT(LOOKS_LIKE_PTR(w->key));
 317         ASSERT(LOOKS_LIKE_PTR(w->value));
 318         ASSERT(LOOKS_LIKE_PTR(w->finalizer));
 319         if (w->link) {
 320           ASSERT(LOOKS_LIKE_PTR(w->link));
 321         }
 322         return sizeW_fromITBL(info);
 323       }
 324
 325     case THUNK_SELECTOR:
 326             ASSERT(LOOKS_LIKE_PTR(stgCast(StgSelector*,p)->selectee));
 327             return sizeofW(StgHeader) + MIN_UPD_SIZE;
 328
 329     case IND:
 330         {
 331             /* we don't expect to see any of these after GC
 332              * but they might appear during execution
 333              */
 334             P_ q;
 335             StgInd *ind = stgCast(StgInd*,p);
 336             ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
 337             q = (P_)p + sizeofW(StgInd);
 338             while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/
 339             return q - (P_)p;
 340         }
 341
 342     case RET_BCO:
 343     case RET_SMALL:
 344     case RET_VEC_SMALL:
 345     case RET_BIG:
 346     case RET_VEC_BIG:
 347     case RET_DYN:
 348     case UPDATE_FRAME:
 349     case STOP_FRAME:
 350     case CATCH_FRAME:
 351     case SEQ_FRAME:
 352             barf("checkClosure: stack frame");
 353
 354     case AP_UPD: /* we can treat this as being the same as a PAP */
 355     case PAP:
 356         {
 357             StgPAP *pap = stgCast(StgPAP*,p);
 358             ASSERT(LOOKS_LIKE_PTR(pap->fun));
 359             checkStackChunk((StgPtr)pap->payload,
 360                             (StgPtr)pap->payload + pap->n_args
 361                             );
 362             return pap_sizeW(pap);
 363         }
 364
 365     case ARR_WORDS:
 366             return arr_words_sizeW(stgCast(StgArrWords*,p));
 367
 368     case MUT_ARR_PTRS:
 369     case MUT_ARR_PTRS_FROZEN:
 370         {
 371             StgMutArrPtrs* a = stgCast(StgMutArrPtrs*,p);
 372             nat i;
 373             for (i = 0; i < a->ptrs; i++) {
 374                 ASSERT(LOOKS_LIKE_PTR(a->payload[i]));
 375             }
 376             return mut_arr_ptrs_sizeW(a);
 377         }
 378
 379     case TSO:
 380         checkTSO((StgTSO *)p);
 381         return tso_sizeW((StgTSO *)p);
 382
 383 #if defined(PAR)
 384
 385     case BLOCKED_FETCH:
 386       ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
 387       ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
 388       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 389
 390 #ifdef DIST
 391     case REMOTE_REF:
 392       return sizeofW(StgFetchMe);
 393 #endif //DIST
 394
 395     case FETCH_ME:
 396       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 397       return sizeofW(StgFetchMe);  // see size used in evacuate()
 398
 399     case FETCH_ME_BQ:
 400       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 401       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 402
 403     case RBH:
 404       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 405       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 406       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 407         checkBQ(((StgRBH *)p)->blocking_queue, p);
 408       ASSERT(LOOKS_LIKE_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 409       return BLACKHOLE_sizeW();   // see size used in evacuate()
 410       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 411
 412 #endif
 413
 414     case EVACUATED:
 415             barf("checkClosure: found EVACUATED closure %d",
 416                  info->type);
 417     default:
 418             barf("checkClosure (closure type %d)", info->type);
 419     }
 420 }
 421
 422 #if defined(PAR)
 423
 424 #define PVM_PE_MASK    0xfffc0000
 425 #define MAX_PVM_PES    MAX_PES
 426 #define MAX_PVM_TIDS   MAX_PES
 427 #define MAX_SLOTS      100000
 428
 429 rtsBool
 430 looks_like_tid(StgInt tid)
 431 {
 432   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 433   StgInt lo = (tid & ~PVM_PE_MASK);
 434   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 435   return ok;
 436 }
 437
 438 rtsBool
 439 looks_like_slot(StgInt slot)
 440 {
 441   /* if tid is known better use looks_like_ga!! */
 442   rtsBool ok = slot<MAX_SLOTS;
 443   // This refers only to the no. of slots on the current PE
 444   // rtsBool ok = slot<=highest_slot();
 445   return ok;
 446 }
 447
 448 rtsBool
 449 looks_like_ga(globalAddr *ga)
 450 {
 451   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 452   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 453                      (ga)->payload.gc.slot<=highest_slot() :
 454                      (ga)->payload.gc.slot<MAX_SLOTS;
 455   rtsBool ok = is_tid && is_slot;
 456   return ok;
 457 }
 458
 459 #endif
 460
 461 //@node Heap Sanity, TSO Sanity, Stack sanity
 462 //@subsection Heap Sanity
 463
 464 /* -----------------------------------------------------------------------------
 465    Check Heap Sanity
 466
 467    After garbage collection, the live heap is in a state where we can
 468    run through and check that all the pointers point to the right
 469    place.  This function starts at a given position and sanity-checks
 470    all the objects in the remainder of the chain.
 471    -------------------------------------------------------------------------- */
 472
 473 //@cindex checkHeap
 474 extern void
 475 checkHeap(bdescr *bd, StgPtr start)
 476 {
 477     StgPtr p;
 478     nat xxx = 0; // tmp -- HWL
 479
 480     if (start == NULL) {
 481       if (bd != NULL) p = bd->start;
 482     } else {
 483       p = start;
 484     }
 485
 486     while (bd != NULL) {
 487       while (p < bd->free) {
 488         nat size = checkClosure(stgCast(StgClosure*,p));
 489         /* This is the smallest size of closure that can live in the heap. */
 490         ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 491         if (get_itbl(stgCast(StgClosure*,p))->type == IND_STATIC)
 492           xxx++;
 493         p += size;
 494
 495         /* skip over slop */
 496         while (p < bd->free &&
 497                (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
 498       }
 499       bd = bd->link;
 500       if (bd != NULL) {
 501         p = bd->start;
 502       }
 503     }
 504     fprintf(stderr,"@@@@ checkHeap: Heap ok; %d IND_STATIC closures checked\n",
 505             xxx);
 506 }
 507
 508 #if defined(PAR)
 509 /*
 510    Check heap between start and end. Used after unpacking graphs.
 511 */
 512 extern void
 513 checkHeapChunk(StgPtr start, StgPtr end)
 514 {
 515   extern globalAddr *LAGAlookup(StgClosure *addr);
 516   StgPtr p;
 517   nat size;
 518
 519   for (p=start; p<end; p+=size) {
 520     ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
 521     if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
 522         *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
 523       /* if it's a FM created during unpack and commoned up, it's not global */
 524       ASSERT(LAGAlookup((StgClosure*)p)==NULL);
 525       size = sizeofW(StgFetchMe);
 526     } else if (get_itbl((StgClosure*)p)->type == IND) {
 527       *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
 528       size = MIN_UPD_SIZE;
 529     } else {
 530       size = checkClosure(stgCast(StgClosure*,p));
 531       /* This is the smallest size of closure that can live in the heap. */
 532       ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 533     }
 534   }
 535 }
 536 #else /* !PAR */
 537 extern void
 538 checkHeapChunk(StgPtr start, StgPtr end)
 539 {
 540   StgPtr p;
 541   nat size;
 542
 543   for (p=start; p<end; p+=size) {
 544     ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
 545     size = checkClosure(stgCast(StgClosure*,p));
 546     /* This is the smallest size of closure that can live in the heap. */
 547     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 548   }
 549 }
 550 #endif
 551
 552 //@cindex checkChain
 553 extern void
 554 checkChain(bdescr *bd)
 555 {
 556   while (bd != NULL) {
 557     checkClosure((StgClosure *)bd->start);
 558     bd = bd->link;
 559   }
 560 }
 561
 562 /* check stack - making sure that update frames are linked correctly */
 563 //@cindex checkStack
 564 void
 565 checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
 566 {
 567     /* check everything down to the first update frame */
 568     checkStackChunk( sp, stgCast(StgPtr,su) );
 569     while ( stgCast(StgPtr,su) < stack_end) {
 570         sp = stgCast(StgPtr,su);
 571         switch (get_itbl(su)->type) {
 572         case UPDATE_FRAME:
 573                 su = su->link;
 574                 break;
 575         case SEQ_FRAME:
 576                 su = stgCast(StgSeqFrame*,su)->link;
 577                 break;
 578         case CATCH_FRAME:
 579                 su = stgCast(StgCatchFrame*,su)->link;
 580                 break;
 581         case STOP_FRAME:
 582                 /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */
 583                 return;
 584         default:
 585                 barf("checkStack: weird record found on update frame list.");
 586         }
 587         checkStackChunk( sp, stgCast(StgPtr,su) );
 588     }
 589     ASSERT(stgCast(StgPtr,su) == stack_end);
 590 }
 591
 592 //@node TSO Sanity, Thread Queue Sanity, Heap Sanity
 593 //@subsection TSO Sanity
 594
 595 //@cindex checkTSO
 596 extern void
 597 checkTSO(StgTSO *tso)
 598 {
 599     StgPtr sp = tso->sp;
 600     StgPtr stack = tso->stack;
 601     StgUpdateFrame* su = tso->su;
 602     StgOffset stack_size = tso->stack_size;
 603     StgPtr stack_end = stack + stack_size;
 604
 605     if (tso->what_next == ThreadRelocated) {
 606       checkTSO(tso->link);
 607       return;
 608     }
 609
 610     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
 611       /* The garbage collector doesn't bother following any pointers
 612        * from dead threads, so don't check sanity here.
 613        */
 614       return;
 615     }
 616
 617     ASSERT(stack <= sp && sp < stack_end);
 618     ASSERT(sp <= stgCast(StgPtr,su));
 619
 620 #if defined(PAR)
 621     ASSERT(tso->par.magic==TSO_MAGIC);
 622
 623     switch (tso->why_blocked) {
 624     case BlockedOnGA:
 625       checkClosureShallow(tso->block_info.closure);
 626       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 627              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 628       break;
 629     case BlockedOnGA_NoSend:
 630       checkClosureShallow(tso->block_info.closure);
 631       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 632       break;
 633     case BlockedOnBlackHole:
 634       checkClosureShallow(tso->block_info.closure);
 635       ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
 636              get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
 637              get_itbl(tso->block_info.closure)->type==RBH);
 638       break;
 639     case BlockedOnRead:
 640     case BlockedOnWrite:
 641     case BlockedOnDelay:
 642       /* isOnBQ(blocked_queue) */
 643       break;
 644     case BlockedOnException:
 645       /* isOnSomeBQ(tso) */
 646       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 647       break;
 648     case BlockedOnMVar:
 649       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 650       break;
 651     default:
 652       /*
 653          Could check other values of why_blocked but I am more
 654          lazy than paranoid (bad combination) -- HWL
 655       */
 656     }
 657
 658     /* if the link field is non-nil it most point to one of these
 659        three closure types */
 660     ASSERT(tso->link == END_TSO_QUEUE ||
 661            get_itbl(tso->link)->type == TSO ||
 662            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 663            get_itbl(tso->link)->type == CONSTR);
 664 #endif
 665
 666     checkStack(sp, stack_end, su);
 667 }
 668
 669 #if defined(GRAN)
 670 //@cindex checkTSOsSanity
 671 extern void
 672 checkTSOsSanity(void) {
 673   nat i, tsos;
 674   StgTSO *tso;
 675
 676   belch("Checking sanity of all runnable TSOs:");
 677
 678   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 679     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 680       fprintf(stderr, "TSO %p on PE %d ...", tso, i);
 681       checkTSO(tso);
 682       fprintf(stderr, "OK, ");
 683       tsos++;
 684     }
 685   }
 686
 687   belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 688 }
 689
 690 //@node Thread Queue Sanity, Blackhole Sanity, TSO Sanity
 691 //@subsection Thread Queue Sanity
 692
 693 // still GRAN only
 694
 695 //@cindex checkThreadQSanity
 696 extern rtsBool
 697 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 698 {
 699   StgTSO *tso, *prev;
 700
 701   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 702   ASSERT(run_queue_hds[proc]!=NULL);
 703   ASSERT(run_queue_tls[proc]!=NULL);
 704   /* if either head or tail is NIL then the other one must be NIL, too */
 705   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 706   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 707   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 708        tso!=END_TSO_QUEUE;
 709        prev=tso, tso=tso->link) {
 710     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 711            (prev==END_TSO_QUEUE || prev->link==tso));
 712     if (check_TSO_too)
 713       checkTSO(tso);
 714   }
 715   ASSERT(prev==run_queue_tls[proc]);
 716 }
 717
 718 //@cindex checkThreadQsSanity
 719 extern rtsBool
 720 checkThreadQsSanity (rtsBool check_TSO_too)
 721 {
 722   PEs p;
 723
 724   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 725     checkThreadQSanity(p, check_TSO_too);
 726 }
 727 #endif /* GRAN */
 728
 729 /*
 730    Check that all TSOs have been evacuated.
 731    Optionally also check the sanity of the TSOs.
 732 */
 733 void
 734 checkGlobalTSOList (rtsBool checkTSOs)
 735 {
 736   extern  StgTSO *all_threads;
 737   StgTSO *tso;
 738   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 739     ASSERT(Bdescr((P_)tso)->evacuated == 1);
 740     if (checkTSOs)
 741       checkTSO(tso);
 742   }
 743 }
 744
 745 //@node Blackhole Sanity, GALA table sanity, Thread Queue Sanity
 746 //@subsection Blackhole Sanity
 747
 748 /* -----------------------------------------------------------------------------
 749    Check Blackhole Sanity
 750
 751    Test whether an object is already on the update list.
 752    It isn't necessarily an rts error if it is - it might be a programming
 753    error.
 754
 755    Future versions might be able to test for a blackhole without traversing
 756    the update frame list.
 757
 758    -------------------------------------------------------------------------- */
 759 //@cindex isBlackhole
 760 rtsBool
 761 isBlackhole( StgTSO* tso, StgClosure* p )
 762 {
 763   StgUpdateFrame* su = tso->su;
 764   do {
 765     switch (get_itbl(su)->type) {
 766     case UPDATE_FRAME:
 767       if (su->updatee == p) {
 768         return rtsTrue;
 769       } else {
 770         su = su->link;
 771       }
 772       break;
 773     case SEQ_FRAME:
 774       su = stgCast(StgSeqFrame*,su)->link;
 775       break;
 776     case CATCH_FRAME:
 777       su = stgCast(StgCatchFrame*,su)->link;
 778       break;
 779     case STOP_FRAME:
 780       return rtsFalse;
 781     default:
 782       barf("isBlackhole: weird record found on update frame list.");
 783     }
 784   } while (1);
 785 }
 786
 787 /*
 788   Check the static objects list.
 789 */
 790 extern void
 791 checkStaticObjects ( void ) {
 792   extern StgClosure* static_objects;
 793   StgClosure *p = static_objects;
 794   StgInfoTable *info;
 795
 796   while (p != END_OF_STATIC_LIST) {
 797     checkClosure(p);
 798     info = get_itbl(p);
 799     switch (info->type) {
 800     case IND_STATIC:
 801       {
 802         StgClosure *indirectee = stgCast(StgIndStatic*,p)->indirectee;
 803
 804         ASSERT(LOOKS_LIKE_PTR(indirectee));
 805         ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info));
 806         p = IND_STATIC_LINK((StgClosure *)p);
 807         break;
 808       }
 809
 810     case THUNK_STATIC:
 811       p = THUNK_STATIC_LINK((StgClosure *)p);
 812       break;
 813
 814     case FUN_STATIC:
 815       p = FUN_STATIC_LINK((StgClosure *)p);
 816       break;
 817
 818     case CONSTR_STATIC:
 819       p = STATIC_LINK(info,(StgClosure *)p);
 820       break;
 821
 822     default:
 823       barf("checkStaticObjetcs: strange closure %p (%s)",
 824            p, info_type(p));
 825     }
 826   }
 827 }
 828
 829 /*
 830    Check the sanity of a blocking queue starting at bqe with closure being
 831    the closure holding the blocking queue.
 832    Note that in GUM we can have several different closure types in a
 833    blocking queue
 834 */
 835 //@cindex checkBQ
 836 #if defined(PAR)
 837 void
 838 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 839 {
 840   rtsBool end = rtsFalse;
 841   StgInfoTable *info = get_itbl(closure);
 842
 843   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
 844          || info->type == FETCH_ME_BQ || info->type == RBH);
 845
 846   do {
 847     switch (get_itbl(bqe)->type) {
 848     case BLOCKED_FETCH:
 849     case TSO:
 850       checkClosure((StgClosure *)bqe);
 851       bqe = bqe->link;
 852       end = (bqe==END_BQ_QUEUE);
 853       break;
 854
 855     case CONSTR:
 856       checkClosure((StgClosure *)bqe);
 857       end = rtsTrue;
 858       break;
 859
 860     default:
 861       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 862            get_itbl(bqe)->type, closure, info_type(closure));
 863     }
 864   } while (!end);
 865 }
 866 #elif defined(GRAN)
 867 void
 868 checkBQ (StgTSO *bqe, StgClosure *closure)
 869 {
 870   rtsBool end = rtsFalse;
 871   StgInfoTable *info = get_itbl(closure);
 872
 873   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 874
 875   do {
 876     switch (get_itbl(bqe)->type) {
 877     case BLOCKED_FETCH:
 878     case TSO:
 879       checkClosure((StgClosure *)bqe);
 880       bqe = bqe->link;
 881       end = (bqe==END_BQ_QUEUE);
 882       break;
 883
 884     default:
 885       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 886            get_itbl(bqe)->type, closure, info_type(closure));
 887     }
 888   } while (!end);
 889 }
 890 #else
 891 void
 892 checkBQ (StgTSO *bqe, StgClosure *closure)
 893 {
 894   rtsBool end = rtsFalse;
 895   StgInfoTable *info = get_itbl(closure);
 896
 897   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 898
 899   do {
 900     switch (get_itbl(bqe)->type) {
 901     case TSO:
 902       checkClosure((StgClosure *)bqe);
 903       bqe = bqe->link;
 904       end = (bqe==END_TSO_QUEUE);
 905       break;
 906
 907     default:
 908       barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
 909            get_itbl(bqe)->type, closure, info->type);
 910     }
 911   } while (!end);
 912 }
 913
 914 #endif
 915
 916
 917 //@node GALA table sanity, Index, Blackhole Sanity
 918 //@subsection GALA table sanity
 919
 920 /*
 921   This routine checks the sanity of the LAGA and GALA tables. They are
 922   implemented as lists through one hash table, LAtoGALAtable, because entries
 923   in both tables have the same structure:
 924    - the LAGA table maps local addresses to global addresses; it starts
 925      with liveIndirections
 926    - the GALA table maps global addresses to local addresses; it starts
 927      with liveRemoteGAs
 928 */
 929
 930 #if defined(PAR)
 931 #include "Hash.h"
 932
 933 /* hidden in parallel/Global.c; only accessed for testing here */
 934 extern GALA *liveIndirections;
 935 extern GALA *liveRemoteGAs;
 936 extern HashTable *LAtoGALAtable;
 937
 938 //@cindex checkLAGAtable
 939 void
 940 checkLAGAtable(rtsBool check_closures)
 941 {
 942   GALA *gala, *gala0;
 943   nat n=0, m=0; // debugging
 944
 945   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 946     n++;
 947     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 948     ASSERT(!gala->preferred || gala == gala0);
 949     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 950     ASSERT(gala->next!=gala); // detect direct loops
 951     if ( check_closures ) {
 952       checkClosure(stgCast(StgClosure*,gala->la));
 953     }
 954   }
 955
 956   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 957     m++;
 958     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 959     ASSERT(!gala->preferred || gala == gala0);
 960     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 961     ASSERT(gala->next!=gala); // detect direct loops
 962     /*
 963     if ( check_closures ) {
 964       checkClosure(stgCast(StgClosure*,gala->la));
 965     }
 966     */
 967   }
 968 }
 969 #endif
 970
 971 //@node Index,  , GALA table sanity
 972 //@subsection Index
 973
 974 #endif /* DEBUG */
 975
 976 //@index
 977 //* checkBQ::  @cindex\s-+checkBQ
 978 //* checkChain::  @cindex\s-+checkChain
 979 //* checkClosureShallow::  @cindex\s-+checkClosureShallow
 980 //* checkHeap::  @cindex\s-+checkHeap
 981 //* checkLargeBitmap::  @cindex\s-+checkLargeBitmap
 982 //* checkSmallBitmap::  @cindex\s-+checkSmallBitmap
 983 //* checkStack::  @cindex\s-+checkStack
 984 //* checkStackChunk::  @cindex\s-+checkStackChunk
 985 //* checkStackChunk::  @cindex\s-+checkStackChunk
 986 //* checkStackClosure::  @cindex\s-+checkStackClosure
 987 //* checkStackObject::  @cindex\s-+checkStackObject
 988 //* checkTSO::  @cindex\s-+checkTSO
 989 //* checkTSOsSanity::  @cindex\s-+checkTSOsSanity
 990 //* checkThreadQSanity::  @cindex\s-+checkThreadQSanity
 991 //* checkThreadQsSanity::  @cindex\s-+checkThreadQsSanity
 992 //* isBlackhole::  @cindex\s-+isBlackhole
 993 //@end index