ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.26 2001/02/09 13:09:16 simonmar 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     case FETCH_ME:
 391       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 392       return sizeofW(StgFetchMe);  // see size used in evacuate()
 393
 394     case FETCH_ME_BQ:
 395       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 396       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 397
 398     case RBH:
 399       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 400       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 401       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 402         checkBQ(((StgRBH *)p)->blocking_queue, p);
 403       ASSERT(LOOKS_LIKE_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 404       return BLACKHOLE_sizeW();   // see size used in evacuate()
 405       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 406
 407 #endif
 408
 409     case EVACUATED:
 410             barf("checkClosure: found EVACUATED closure %d",
 411                  info->type);
 412     default:
 413             barf("checkClosure (closure type %d)", info->type);
 414     }
 415 }
 416
 417 #if defined(PAR)
 418
 419 #define PVM_PE_MASK    0xfffc0000
 420 #define MAX_PVM_PES    MAX_PES
 421 #define MAX_PVM_TIDS   MAX_PES
 422 #define MAX_SLOTS      100000
 423
 424 rtsBool
 425 looks_like_tid(StgInt tid)
 426 {
 427   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 428   StgInt lo = (tid & ~PVM_PE_MASK);
 429   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 430   return ok;
 431 }
 432
 433 rtsBool
 434 looks_like_slot(StgInt slot)
 435 {
 436   /* if tid is known better use looks_like_ga!! */
 437   rtsBool ok = slot<MAX_SLOTS;
 438   // This refers only to the no. of slots on the current PE
 439   // rtsBool ok = slot<=highest_slot();
 440   return ok;
 441 }
 442
 443 rtsBool
 444 looks_like_ga(globalAddr *ga)
 445 {
 446   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 447   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 448                      (ga)->payload.gc.slot<=highest_slot() :
 449                      (ga)->payload.gc.slot<MAX_SLOTS;
 450   rtsBool ok = is_tid && is_slot;
 451   return ok;
 452 }
 453
 454 #endif
 455
 456 //@node Heap Sanity, TSO Sanity, Stack sanity
 457 //@subsection Heap Sanity
 458
 459 /* -----------------------------------------------------------------------------
 460    Check Heap Sanity
 461
 462    After garbage collection, the live heap is in a state where we can
 463    run through and check that all the pointers point to the right
 464    place.  This function starts at a given position and sanity-checks
 465    all the objects in the remainder of the chain.
 466    -------------------------------------------------------------------------- */
 467
 468 //@cindex checkHeap
 469 extern void
 470 checkHeap(bdescr *bd, StgPtr start)
 471 {
 472     StgPtr p;
 473     nat xxx = 0; // tmp -- HWL
 474
 475     if (start == NULL) {
 476       if (bd != NULL) p = bd->start;
 477     } else {
 478       p = start;
 479     }
 480
 481     while (bd != NULL) {
 482       while (p < bd->free) {
 483         nat size = checkClosure(stgCast(StgClosure*,p));
 484         /* This is the smallest size of closure that can live in the heap. */
 485         ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 486         if (get_itbl(stgCast(StgClosure*,p))->type == IND_STATIC)
 487           xxx++;
 488         p += size;
 489
 490         /* skip over slop */
 491         while (p < bd->free &&
 492                (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
 493       }
 494       bd = bd->link;
 495       if (bd != NULL) {
 496         p = bd->start;
 497       }
 498     }
 499     fprintf(stderr,"@@@@ checkHeap: Heap ok; %d IND_STATIC closures checked\n",
 500             xxx);
 501 }
 502
 503 /*
 504    Check heap between start and end. Used after unpacking graphs.
 505 */
 506 extern void
 507 checkHeapChunk(StgPtr start, StgPtr end)
 508 {
 509   StgPtr p;
 510   nat size;
 511
 512   for (p=start; p<end; p+=size) {
 513     ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
 514     size = checkClosure(stgCast(StgClosure*,p));
 515     /* This is the smallest size of closure that can live in the heap. */
 516     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 517   }
 518 }
 519
 520 //@cindex checkChain
 521 extern void
 522 checkChain(bdescr *bd)
 523 {
 524   while (bd != NULL) {
 525     checkClosure((StgClosure *)bd->start);
 526     bd = bd->link;
 527   }
 528 }
 529
 530 /* check stack - making sure that update frames are linked correctly */
 531 //@cindex checkStack
 532 void
 533 checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
 534 {
 535     /* check everything down to the first update frame */
 536     checkStackChunk( sp, stgCast(StgPtr,su) );
 537     while ( stgCast(StgPtr,su) < stack_end) {
 538         sp = stgCast(StgPtr,su);
 539         switch (get_itbl(su)->type) {
 540         case UPDATE_FRAME:
 541                 su = su->link;
 542                 break;
 543         case SEQ_FRAME:
 544                 su = stgCast(StgSeqFrame*,su)->link;
 545                 break;
 546         case CATCH_FRAME:
 547                 su = stgCast(StgCatchFrame*,su)->link;
 548                 break;
 549         case STOP_FRAME:
 550                 /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */
 551                 return;
 552         default:
 553                 barf("checkStack: weird record found on update frame list.");
 554         }
 555         checkStackChunk( sp, stgCast(StgPtr,su) );
 556     }
 557     ASSERT(stgCast(StgPtr,su) == stack_end);
 558 }
 559
 560 //@node TSO Sanity, Thread Queue Sanity, Heap Sanity
 561 //@subsection TSO Sanity
 562
 563 //@cindex checkTSO
 564 extern void
 565 checkTSO(StgTSO *tso)
 566 {
 567     StgPtr sp = tso->sp;
 568     StgPtr stack = tso->stack;
 569     StgUpdateFrame* su = tso->su;
 570     StgOffset stack_size = tso->stack_size;
 571     StgPtr stack_end = stack + stack_size;
 572
 573     if (tso->what_next == ThreadRelocated) {
 574       checkTSO(tso->link);
 575       return;
 576     }
 577
 578     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
 579       /* The garbage collector doesn't bother following any pointers
 580        * from dead threads, so don't check sanity here.
 581        */
 582       return;
 583     }
 584
 585     ASSERT(stack <= sp && sp < stack_end);
 586     ASSERT(sp <= stgCast(StgPtr,su));
 587
 588 #if defined(PAR)
 589     ASSERT(tso->par.magic==TSO_MAGIC);
 590
 591     switch (tso->why_blocked) {
 592     case BlockedOnGA:
 593       checkClosureShallow(tso->block_info.closure);
 594       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 595              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 596       break;
 597     case BlockedOnGA_NoSend:
 598       checkClosureShallow(tso->block_info.closure);
 599       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 600       break;
 601     case BlockedOnBlackHole:
 602       checkClosureShallow(tso->block_info.closure);
 603       ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
 604              get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
 605              get_itbl(tso->block_info.closure)->type==RBH);
 606       break;
 607     case BlockedOnRead:
 608     case BlockedOnWrite:
 609     case BlockedOnDelay:
 610       /* isOnBQ(blocked_queue) */
 611       break;
 612     case BlockedOnException:
 613       /* isOnSomeBQ(tso) */
 614       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 615       break;
 616     case BlockedOnMVar:
 617       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 618       break;
 619     default:
 620       /*
 621          Could check other values of why_blocked but I am more
 622          lazy than paranoid (bad combination) -- HWL
 623       */
 624     }
 625
 626     /* if the link field is non-nil it most point to one of these
 627        three closure types */
 628     ASSERT(tso->link == END_TSO_QUEUE ||
 629            get_itbl(tso->link)->type == TSO ||
 630            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 631            get_itbl(tso->link)->type == CONSTR);
 632 #endif
 633
 634     checkStack(sp, stack_end, su);
 635 }
 636
 637 #if defined(GRAN)
 638 //@cindex checkTSOsSanity
 639 extern void
 640 checkTSOsSanity(void) {
 641   nat i, tsos;
 642   StgTSO *tso;
 643
 644   belch("Checking sanity of all runnable TSOs:");
 645
 646   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 647     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 648       fprintf(stderr, "TSO %p on PE %d ...", tso, i);
 649       checkTSO(tso);
 650       fprintf(stderr, "OK, ");
 651       tsos++;
 652     }
 653   }
 654
 655   belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 656 }
 657
 658 //@node Thread Queue Sanity, Blackhole Sanity, TSO Sanity
 659 //@subsection Thread Queue Sanity
 660
 661 // still GRAN only
 662
 663 //@cindex checkThreadQSanity
 664 extern rtsBool
 665 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 666 {
 667   StgTSO *tso, *prev;
 668
 669   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 670   ASSERT(run_queue_hds[proc]!=NULL);
 671   ASSERT(run_queue_tls[proc]!=NULL);
 672   /* if either head or tail is NIL then the other one must be NIL, too */
 673   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 674   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 675   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 676        tso!=END_TSO_QUEUE;
 677        prev=tso, tso=tso->link) {
 678     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 679            (prev==END_TSO_QUEUE || prev->link==tso));
 680     if (check_TSO_too)
 681       checkTSO(tso);
 682   }
 683   ASSERT(prev==run_queue_tls[proc]);
 684 }
 685
 686 //@cindex checkThreadQsSanity
 687 extern rtsBool
 688 checkThreadQsSanity (rtsBool check_TSO_too)
 689 {
 690   PEs p;
 691
 692   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 693     checkThreadQSanity(p, check_TSO_too);
 694 }
 695 #endif /* GRAN */
 696
 697 /*
 698    Check that all TSOs have been evacuated.
 699    Optionally also check the sanity of the TSOs.
 700 */
 701 void
 702 checkGlobalTSOList (rtsBool checkTSOs)
 703 {
 704   extern  StgTSO *all_threads;
 705   StgTSO *tso;
 706   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 707     ASSERT(Bdescr((P_)tso)->evacuated == 1);
 708     if (checkTSOs)
 709       checkTSO(tso);
 710   }
 711 }
 712
 713 //@node Blackhole Sanity, GALA table sanity, Thread Queue Sanity
 714 //@subsection Blackhole Sanity
 715
 716 /* -----------------------------------------------------------------------------
 717    Check Blackhole Sanity
 718
 719    Test whether an object is already on the update list.
 720    It isn't necessarily an rts error if it is - it might be a programming
 721    error.
 722
 723    Future versions might be able to test for a blackhole without traversing
 724    the update frame list.
 725
 726    -------------------------------------------------------------------------- */
 727 //@cindex isBlackhole
 728 rtsBool
 729 isBlackhole( StgTSO* tso, StgClosure* p )
 730 {
 731   StgUpdateFrame* su = tso->su;
 732   do {
 733     switch (get_itbl(su)->type) {
 734     case UPDATE_FRAME:
 735       if (su->updatee == p) {
 736         return rtsTrue;
 737       } else {
 738         su = su->link;
 739       }
 740       break;
 741     case SEQ_FRAME:
 742       su = stgCast(StgSeqFrame*,su)->link;
 743       break;
 744     case CATCH_FRAME:
 745       su = stgCast(StgCatchFrame*,su)->link;
 746       break;
 747     case STOP_FRAME:
 748       return rtsFalse;
 749     default:
 750       barf("isBlackhole: weird record found on update frame list.");
 751     }
 752   } while (1);
 753 }
 754
 755 /*
 756   Check the static objects list.
 757 */
 758 extern void
 759 checkStaticObjects ( void ) {
 760   extern StgClosure* static_objects;
 761   StgClosure *p = static_objects;
 762   StgInfoTable *info;
 763
 764   while (p != END_OF_STATIC_LIST) {
 765     checkClosure(p);
 766     info = get_itbl(p);
 767     switch (info->type) {
 768     case IND_STATIC:
 769       {
 770         StgClosure *indirectee = stgCast(StgIndStatic*,p)->indirectee;
 771
 772         ASSERT(LOOKS_LIKE_PTR(indirectee));
 773         ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info));
 774         p = IND_STATIC_LINK((StgClosure *)p);
 775         break;
 776       }
 777
 778     case THUNK_STATIC:
 779       p = THUNK_STATIC_LINK((StgClosure *)p);
 780       break;
 781
 782     case FUN_STATIC:
 783       p = FUN_STATIC_LINK((StgClosure *)p);
 784       break;
 785
 786     case CONSTR_STATIC:
 787       p = STATIC_LINK(info,(StgClosure *)p);
 788       break;
 789
 790     default:
 791       barf("checkStaticObjetcs: strange closure %p (%s)",
 792            p, info_type(p));
 793     }
 794   }
 795 }
 796
 797 /*
 798    Check the sanity of a blocking queue starting at bqe with closure being
 799    the closure holding the blocking queue.
 800    Note that in GUM we can have several different closure types in a
 801    blocking queue
 802 */
 803 //@cindex checkBQ
 804 #if defined(PAR)
 805 void
 806 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 807 {
 808   rtsBool end = rtsFalse;
 809   StgInfoTable *info = get_itbl(closure);
 810
 811   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
 812          || info->type == FETCH_ME_BQ || info->type == RBH);
 813
 814   do {
 815     switch (get_itbl(bqe)->type) {
 816     case BLOCKED_FETCH:
 817     case TSO:
 818       checkClosure((StgClosure *)bqe);
 819       bqe = bqe->link;
 820       end = (bqe==END_BQ_QUEUE);
 821       break;
 822
 823     case CONSTR:
 824       checkClosure((StgClosure *)bqe);
 825       end = rtsTrue;
 826       break;
 827
 828     default:
 829       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 830            get_itbl(bqe)->type, closure, info_type(closure));
 831     }
 832   } while (!end);
 833 }
 834 #elif defined(GRAN)
 835 void
 836 checkBQ (StgTSO *bqe, StgClosure *closure)
 837 {
 838   rtsBool end = rtsFalse;
 839   StgInfoTable *info = get_itbl(closure);
 840
 841   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 842
 843   do {
 844     switch (get_itbl(bqe)->type) {
 845     case BLOCKED_FETCH:
 846     case TSO:
 847       checkClosure((StgClosure *)bqe);
 848       bqe = bqe->link;
 849       end = (bqe==END_BQ_QUEUE);
 850       break;
 851
 852     default:
 853       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 854            get_itbl(bqe)->type, closure, info_type(closure));
 855     }
 856   } while (!end);
 857 }
 858 #else
 859 void
 860 checkBQ (StgTSO *bqe, StgClosure *closure)
 861 {
 862   rtsBool end = rtsFalse;
 863   StgInfoTable *info = get_itbl(closure);
 864
 865   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 866
 867   do {
 868     switch (get_itbl(bqe)->type) {
 869     case TSO:
 870       checkClosure((StgClosure *)bqe);
 871       bqe = bqe->link;
 872       end = (bqe==END_TSO_QUEUE);
 873       break;
 874
 875     default:
 876       barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
 877            get_itbl(bqe)->type, closure, info->type);
 878     }
 879   } while (!end);
 880 }
 881
 882 #endif
 883
 884
 885 //@node GALA table sanity, Index, Blackhole Sanity
 886 //@subsection GALA table sanity
 887
 888 /*
 889   This routine checks the sanity of the LAGA and GALA tables. They are
 890   implemented as lists through one hash table, LAtoGALAtable, because entries
 891   in both tables have the same structure:
 892    - the LAGA table maps local addresses to global addresses; it starts
 893      with liveIndirections
 894    - the GALA table maps global addresses to local addresses; it starts
 895      with liveRemoteGAs
 896 */
 897
 898 #if defined(PAR)
 899 #include "Hash.h"
 900
 901 /* hidden in parallel/Global.c; only accessed for testing here */
 902 extern GALA *liveIndirections;
 903 extern GALA *liveRemoteGAs;
 904 extern HashTable *LAtoGALAtable;
 905
 906 //@cindex checkLAGAtable
 907 void
 908 checkLAGAtable(rtsBool check_closures)
 909 {
 910   GALA *gala, *gala0;
 911   nat n=0, m=0; // debugging
 912
 913   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 914     n++;
 915     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 916     ASSERT(!gala->preferred || gala == gala0);
 917     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 918     ASSERT(gala->next!=gala); // detect direct loops
 919     /*
 920     if ( check_closures ) {
 921       checkClosure(stgCast(StgClosure*,gala->la));
 922     }
 923     */
 924   }
 925
 926   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 927     m++;
 928     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 929     ASSERT(!gala->preferred || gala == gala0);
 930     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 931     ASSERT(gala->next!=gala); // detect direct loops
 932     /*
 933     if ( check_closures ) {
 934       checkClosure(stgCast(StgClosure*,gala->la));
 935     }
 936     */
 937   }
 938 }
 939 #endif
 940
 941 //@node Index,  , GALA table sanity
 942 //@subsection Index
 943
 944 #endif /* DEBUG */
 945
 946 //@index
 947 //* checkBQ::  @cindex\s-+checkBQ
 948 //* checkChain::  @cindex\s-+checkChain
 949 //* checkClosureShallow::  @cindex\s-+checkClosureShallow
 950 //* checkHeap::  @cindex\s-+checkHeap
 951 //* checkLargeBitmap::  @cindex\s-+checkLargeBitmap
 952 //* checkSmallBitmap::  @cindex\s-+checkSmallBitmap
 953 //* checkStack::  @cindex\s-+checkStack
 954 //* checkStackChunk::  @cindex\s-+checkStackChunk
 955 //* checkStackChunk::  @cindex\s-+checkStackChunk
 956 //* checkStackClosure::  @cindex\s-+checkStackClosure
 957 //* checkStackObject::  @cindex\s-+checkStackObject
 958 //* checkTSO::  @cindex\s-+checkTSO
 959 //* checkTSOsSanity::  @cindex\s-+checkTSOsSanity
 960 //* checkThreadQSanity::  @cindex\s-+checkThreadQSanity
 961 //* checkThreadQsSanity::  @cindex\s-+checkThreadQsSanity
 962 //* isBlackhole::  @cindex\s-+isBlackhole
 963 //@end index