ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.24 2000/12/11 12:37:00 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 #ifndef INTERPRETER
 223     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
 224 #endif
 225
 226     /* Is it a static closure (i.e. in the data segment)? */
 227     if (LOOKS_LIKE_STATIC(p)) {
 228         ASSERT(closure_STATIC(p));
 229     } else {
 230         ASSERT(!closure_STATIC(p));
 231         ASSERT(LOOKS_LIKE_PTR(p));
 232     }
 233
 234     info = get_itbl(p);
 235     switch (info->type) {
 236
 237     case MVAR:
 238       {
 239         StgMVar *mvar = (StgMVar *)p;
 240         ASSERT(LOOKS_LIKE_PTR(mvar->head));
 241         ASSERT(LOOKS_LIKE_PTR(mvar->tail));
 242         ASSERT(LOOKS_LIKE_PTR(mvar->value));
 243 #if 0
 244 #if defined(PAR)
 245         checkBQ((StgBlockingQueueElement *)mvar->head, p);
 246 #else
 247         checkBQ(mvar->head, p);
 248 #endif
 249 #endif
 250         return sizeofW(StgMVar);
 251       }
 252
 253     case THUNK:
 254     case THUNK_1_0:
 255     case THUNK_0_1:
 256     case THUNK_1_1:
 257     case THUNK_0_2:
 258     case THUNK_2_0:
 259       {
 260         nat i;
 261         for (i = 0; i < info->layout.payload.ptrs; i++) {
 262           ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 263         }
 264         return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
 265       }
 266
 267     case BLACKHOLE_BQ:
 268       checkBQ(((StgBlockingQueue *)p)->blocking_queue, p);
 269       /* fall through to basic ptr check */
 270     case FUN:
 271     case FUN_1_0:
 272     case FUN_0_1:
 273     case FUN_1_1:
 274     case FUN_0_2:
 275     case FUN_2_0:
 276     case CONSTR:
 277     case CONSTR_1_0:
 278     case CONSTR_0_1:
 279     case CONSTR_1_1:
 280     case CONSTR_0_2:
 281     case CONSTR_2_0:
 282     case IND_PERM:
 283     case IND_OLDGEN:
 284     case IND_OLDGEN_PERM:
 285     case CAF_UNENTERED:
 286     case CAF_ENTERED:
 287     case CAF_BLACKHOLE:
 288 #ifdef TICKY_TICKY
 289     case SE_CAF_BLACKHOLE:
 290     case SE_BLACKHOLE:
 291 #endif
 292     case BLACKHOLE:
 293     case FOREIGN:
 294     case BCO:
 295     case STABLE_NAME:
 296     case MUT_VAR:
 297     case CONSTR_INTLIKE:
 298     case CONSTR_CHARLIKE:
 299     case CONSTR_STATIC:
 300     case CONSTR_NOCAF_STATIC:
 301     case THUNK_STATIC:
 302     case FUN_STATIC:
 303         {
 304             nat i;
 305             for (i = 0; i < info->layout.payload.ptrs; i++) {
 306                 ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 307             }
 308             return sizeW_fromITBL(info);
 309         }
 310
 311     case IND_STATIC: /* (1, 0) closure */
 312       ASSERT(LOOKS_LIKE_PTR(((StgIndStatic*)p)->indirectee));
 313       return sizeW_fromITBL(info);
 314
 315     case WEAK:
 316       /* deal with these specially - the info table isn't
 317        * representative of the actual layout.
 318        */
 319       { StgWeak *w = (StgWeak *)p;
 320         ASSERT(LOOKS_LIKE_PTR(w->key));
 321         ASSERT(LOOKS_LIKE_PTR(w->value));
 322         ASSERT(LOOKS_LIKE_PTR(w->finalizer));
 323         if (w->link) {
 324           ASSERT(LOOKS_LIKE_PTR(w->link));
 325         }
 326         return sizeW_fromITBL(info);
 327       }
 328
 329     case THUNK_SELECTOR:
 330             ASSERT(LOOKS_LIKE_PTR(stgCast(StgSelector*,p)->selectee));
 331             return sizeofW(StgHeader) + MIN_UPD_SIZE;
 332
 333     case IND:
 334         {
 335             /* we don't expect to see any of these after GC
 336              * but they might appear during execution
 337              */
 338             P_ q;
 339             StgInd *ind = stgCast(StgInd*,p);
 340             ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
 341             q = (P_)p + sizeofW(StgInd);
 342             while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/
 343             return q - (P_)p;
 344         }
 345
 346     case RET_BCO:
 347     case RET_SMALL:
 348     case RET_VEC_SMALL:
 349     case RET_BIG:
 350     case RET_VEC_BIG:
 351     case RET_DYN:
 352     case UPDATE_FRAME:
 353     case STOP_FRAME:
 354     case CATCH_FRAME:
 355     case SEQ_FRAME:
 356             barf("checkClosure: stack frame");
 357
 358     case AP_UPD: /* we can treat this as being the same as a PAP */
 359     case PAP:
 360         {
 361             StgPAP *pap = stgCast(StgPAP*,p);
 362             ASSERT(LOOKS_LIKE_PTR(pap->fun));
 363             checkStackChunk((StgPtr)pap->payload,
 364                             (StgPtr)pap->payload + pap->n_args
 365                             );
 366             return pap_sizeW(pap);
 367         }
 368
 369     case ARR_WORDS:
 370             return arr_words_sizeW(stgCast(StgArrWords*,p));
 371
 372     case MUT_ARR_PTRS:
 373     case MUT_ARR_PTRS_FROZEN:
 374         {
 375             StgMutArrPtrs* a = stgCast(StgMutArrPtrs*,p);
 376             nat i;
 377             for (i = 0; i < a->ptrs; i++) {
 378                 ASSERT(LOOKS_LIKE_PTR(a->payload[i]));
 379             }
 380             return mut_arr_ptrs_sizeW(a);
 381         }
 382
 383     case TSO:
 384         checkTSO((StgTSO *)p);
 385         return tso_sizeW((StgTSO *)p);
 386
 387 #if defined(PAR)
 388
 389     case BLOCKED_FETCH:
 390       ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
 391       ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
 392       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 393
 394     case FETCH_ME:
 395       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 396       return sizeofW(StgFetchMe);  // see size used in evacuate()
 397
 398     case FETCH_ME_BQ:
 399       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 400       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 401
 402     case RBH:
 403       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 404       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 405       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 406         checkBQ(((StgRBH *)p)->blocking_queue, p);
 407       ASSERT(LOOKS_LIKE_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 408       return BLACKHOLE_sizeW();   // see size used in evacuate()
 409       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 410
 411 #endif
 412
 413     case EVACUATED:
 414             barf("checkClosure: found EVACUATED closure %d",
 415                  info->type);
 416     default:
 417             barf("checkClosure (closure type %d)", info->type);
 418     }
 419 }
 420
 421 #if defined(PAR)
 422
 423 #define PVM_PE_MASK    0xfffc0000
 424 #define MAX_PVM_PES    MAX_PES
 425 #define MAX_PVM_TIDS   MAX_PES
 426 #define MAX_SLOTS      100000
 427
 428 rtsBool
 429 looks_like_tid(StgInt tid)
 430 {
 431   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 432   StgInt lo = (tid & ~PVM_PE_MASK);
 433   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 434   return ok;
 435 }
 436
 437 rtsBool
 438 looks_like_slot(StgInt slot)
 439 {
 440   /* if tid is known better use looks_like_ga!! */
 441   rtsBool ok = slot<MAX_SLOTS;
 442   // This refers only to the no. of slots on the current PE
 443   // rtsBool ok = slot<=highest_slot();
 444   return ok;
 445 }
 446
 447 rtsBool
 448 looks_like_ga(globalAddr *ga)
 449 {
 450   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 451   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 452                      (ga)->payload.gc.slot<=highest_slot() :
 453                      (ga)->payload.gc.slot<MAX_SLOTS;
 454   rtsBool ok = is_tid && is_slot;
 455   return ok;
 456 }
 457
 458 #endif
 459
 460 //@node Heap Sanity, TSO Sanity, Stack sanity
 461 //@subsection Heap Sanity
 462
 463 /* -----------------------------------------------------------------------------
 464    Check Heap Sanity
 465
 466    After garbage collection, the live heap is in a state where we can
 467    run through and check that all the pointers point to the right
 468    place.  This function starts at a given position and sanity-checks
 469    all the objects in the remainder of the chain.
 470    -------------------------------------------------------------------------- */
 471
 472 //@cindex checkHeap
 473 extern void
 474 checkHeap(bdescr *bd, StgPtr start)
 475 {
 476     StgPtr p;
 477     nat xxx = 0; // tmp -- HWL
 478
 479     if (start == NULL) {
 480       if (bd != NULL) p = bd->start;
 481     } else {
 482       p = start;
 483     }
 484
 485     while (bd != NULL) {
 486       while (p < bd->free) {
 487         nat size = checkClosure(stgCast(StgClosure*,p));
 488         /* This is the smallest size of closure that can live in the heap. */
 489         ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 490         if (get_itbl(stgCast(StgClosure*,p))->type == IND_STATIC)
 491           xxx++;
 492         p += size;
 493
 494         /* skip over slop */
 495         while (p < bd->free &&
 496                (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
 497       }
 498       bd = bd->link;
 499       if (bd != NULL) {
 500         p = bd->start;
 501       }
 502     }
 503     fprintf(stderr,"@@@@ checkHeap: Heap ok; %d IND_STATIC closures checked\n",
 504             xxx);
 505 }
 506
 507 /*
 508    Check heap between start and end. Used after unpacking graphs.
 509 */
 510 extern void
 511 checkHeapChunk(StgPtr start, StgPtr end)
 512 {
 513   StgPtr p;
 514   nat size;
 515
 516   for (p=start; p<end; p+=size) {
 517     ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
 518     size = checkClosure(stgCast(StgClosure*,p));
 519     /* This is the smallest size of closure that can live in the heap. */
 520     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 521   }
 522 }
 523
 524 //@cindex checkChain
 525 extern void
 526 checkChain(bdescr *bd)
 527 {
 528   while (bd != NULL) {
 529     checkClosure((StgClosure *)bd->start);
 530     bd = bd->link;
 531   }
 532 }
 533
 534 /* check stack - making sure that update frames are linked correctly */
 535 //@cindex checkStack
 536 void
 537 checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
 538 {
 539     /* check everything down to the first update frame */
 540     checkStackChunk( sp, stgCast(StgPtr,su) );
 541     while ( stgCast(StgPtr,su) < stack_end) {
 542         sp = stgCast(StgPtr,su);
 543         switch (get_itbl(su)->type) {
 544         case UPDATE_FRAME:
 545                 su = su->link;
 546                 break;
 547         case SEQ_FRAME:
 548                 su = stgCast(StgSeqFrame*,su)->link;
 549                 break;
 550         case CATCH_FRAME:
 551                 su = stgCast(StgCatchFrame*,su)->link;
 552                 break;
 553         case STOP_FRAME:
 554                 /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */
 555                 return;
 556         default:
 557                 barf("checkStack: weird record found on update frame list.");
 558         }
 559         checkStackChunk( sp, stgCast(StgPtr,su) );
 560     }
 561     ASSERT(stgCast(StgPtr,su) == stack_end);
 562 }
 563
 564 //@node TSO Sanity, Thread Queue Sanity, Heap Sanity
 565 //@subsection TSO Sanity
 566
 567 //@cindex checkTSO
 568 extern void
 569 checkTSO(StgTSO *tso)
 570 {
 571     StgPtr sp = tso->sp;
 572     StgPtr stack = tso->stack;
 573     StgUpdateFrame* su = tso->su;
 574     StgOffset stack_size = tso->stack_size;
 575     StgPtr stack_end = stack + stack_size;
 576
 577     if (tso->what_next == ThreadRelocated) {
 578       checkTSO(tso->link);
 579       return;
 580     }
 581
 582     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
 583       /* The garbage collector doesn't bother following any pointers
 584        * from dead threads, so don't check sanity here.
 585        */
 586       return;
 587     }
 588
 589     ASSERT(stack <= sp && sp < stack_end);
 590     ASSERT(sp <= stgCast(StgPtr,su));
 591
 592 #if defined(PAR)
 593     ASSERT(tso->par.magic==TSO_MAGIC);
 594
 595     switch (tso->why_blocked) {
 596     case BlockedOnGA:
 597       checkClosureShallow(tso->block_info.closure);
 598       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 599              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 600       break;
 601     case BlockedOnGA_NoSend:
 602       checkClosureShallow(tso->block_info.closure);
 603       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 604       break;
 605     case BlockedOnBlackHole:
 606       checkClosureShallow(tso->block_info.closure);
 607       ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
 608              get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
 609              get_itbl(tso->block_info.closure)->type==RBH);
 610       break;
 611     case BlockedOnRead:
 612     case BlockedOnWrite:
 613     case BlockedOnDelay:
 614       /* isOnBQ(blocked_queue) */
 615       break;
 616     case BlockedOnException:
 617       /* isOnSomeBQ(tso) */
 618       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 619       break;
 620     case BlockedOnMVar:
 621       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 622       break;
 623     default:
 624       /*
 625          Could check other values of why_blocked but I am more
 626          lazy than paranoid (bad combination) -- HWL
 627       */
 628     }
 629
 630     /* if the link field is non-nil it most point to one of these
 631        three closure types */
 632     ASSERT(tso->link == END_TSO_QUEUE ||
 633            get_itbl(tso->link)->type == TSO ||
 634            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 635            get_itbl(tso->link)->type == CONSTR);
 636 #endif
 637
 638     checkStack(sp, stack_end, su);
 639 }
 640
 641 #if defined(GRAN)
 642 //@cindex checkTSOsSanity
 643 extern void
 644 checkTSOsSanity(void) {
 645   nat i, tsos;
 646   StgTSO *tso;
 647
 648   belch("Checking sanity of all runnable TSOs:");
 649
 650   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 651     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 652       fprintf(stderr, "TSO %p on PE %d ...", tso, i);
 653       checkTSO(tso);
 654       fprintf(stderr, "OK, ");
 655       tsos++;
 656     }
 657   }
 658
 659   belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 660 }
 661
 662 //@node Thread Queue Sanity, Blackhole Sanity, TSO Sanity
 663 //@subsection Thread Queue Sanity
 664
 665 // still GRAN only
 666
 667 //@cindex checkThreadQSanity
 668 extern rtsBool
 669 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 670 {
 671   StgTSO *tso, *prev;
 672
 673   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 674   ASSERT(run_queue_hds[proc]!=NULL);
 675   ASSERT(run_queue_tls[proc]!=NULL);
 676   /* if either head or tail is NIL then the other one must be NIL, too */
 677   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 678   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 679   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 680        tso!=END_TSO_QUEUE;
 681        prev=tso, tso=tso->link) {
 682     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 683            (prev==END_TSO_QUEUE || prev->link==tso));
 684     if (check_TSO_too)
 685       checkTSO(tso);
 686   }
 687   ASSERT(prev==run_queue_tls[proc]);
 688 }
 689
 690 //@cindex checkThreadQsSanity
 691 extern rtsBool
 692 checkThreadQsSanity (rtsBool check_TSO_too)
 693 {
 694   PEs p;
 695
 696   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 697     checkThreadQSanity(p, check_TSO_too);
 698 }
 699 #endif /* GRAN */
 700
 701 /*
 702    Check that all TSOs have been evacuated.
 703    Optionally also check the sanity of the TSOs.
 704 */
 705 void
 706 checkGlobalTSOList (rtsBool checkTSOs)
 707 {
 708   extern  StgTSO *all_threads;
 709   StgTSO *tso;
 710   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 711     ASSERT(Bdescr((P_)tso)->evacuated == 1);
 712     if (checkTSOs)
 713       checkTSO(tso);
 714   }
 715 }
 716
 717 //@node Blackhole Sanity, GALA table sanity, Thread Queue Sanity
 718 //@subsection Blackhole Sanity
 719
 720 /* -----------------------------------------------------------------------------
 721    Check Blackhole Sanity
 722
 723    Test whether an object is already on the update list.
 724    It isn't necessarily an rts error if it is - it might be a programming
 725    error.
 726
 727    Future versions might be able to test for a blackhole without traversing
 728    the update frame list.
 729
 730    -------------------------------------------------------------------------- */
 731 //@cindex isBlackhole
 732 rtsBool
 733 isBlackhole( StgTSO* tso, StgClosure* p )
 734 {
 735   StgUpdateFrame* su = tso->su;
 736   do {
 737     switch (get_itbl(su)->type) {
 738     case UPDATE_FRAME:
 739       if (su->updatee == p) {
 740         return rtsTrue;
 741       } else {
 742         su = su->link;
 743       }
 744       break;
 745     case SEQ_FRAME:
 746       su = stgCast(StgSeqFrame*,su)->link;
 747       break;
 748     case CATCH_FRAME:
 749       su = stgCast(StgCatchFrame*,su)->link;
 750       break;
 751     case STOP_FRAME:
 752       return rtsFalse;
 753     default:
 754       barf("isBlackhole: weird record found on update frame list.");
 755     }
 756   } while (1);
 757 }
 758
 759 /*
 760   Check the static objects list.
 761 */
 762 extern void
 763 checkStaticObjects ( void ) {
 764   extern StgClosure* static_objects;
 765   StgClosure *p = static_objects;
 766   StgInfoTable *info;
 767
 768   while (p != END_OF_STATIC_LIST) {
 769     checkClosure(p);
 770     info = get_itbl(p);
 771     switch (info->type) {
 772     case IND_STATIC:
 773       {
 774         StgClosure *indirectee = stgCast(StgIndStatic*,p)->indirectee;
 775
 776         ASSERT(LOOKS_LIKE_PTR(indirectee));
 777         ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info));
 778         p = IND_STATIC_LINK((StgClosure *)p);
 779         break;
 780       }
 781
 782     case THUNK_STATIC:
 783       p = THUNK_STATIC_LINK((StgClosure *)p);
 784       break;
 785
 786     case FUN_STATIC:
 787       p = FUN_STATIC_LINK((StgClosure *)p);
 788       break;
 789
 790     case CONSTR_STATIC:
 791       p = STATIC_LINK(info,(StgClosure *)p);
 792       break;
 793
 794     default:
 795       barf("checkStaticObjetcs: strange closure %p (%s)",
 796            p, info_type(p));
 797     }
 798   }
 799 }
 800
 801 /*
 802    Check the sanity of a blocking queue starting at bqe with closure being
 803    the closure holding the blocking queue.
 804    Note that in GUM we can have several different closure types in a
 805    blocking queue
 806 */
 807 //@cindex checkBQ
 808 #if defined(PAR)
 809 void
 810 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 811 {
 812   rtsBool end = rtsFalse;
 813   StgInfoTable *info = get_itbl(closure);
 814
 815   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
 816          || info->type == FETCH_ME_BQ || info->type == RBH);
 817
 818   do {
 819     switch (get_itbl(bqe)->type) {
 820     case BLOCKED_FETCH:
 821     case TSO:
 822       checkClosure((StgClosure *)bqe);
 823       bqe = bqe->link;
 824       end = (bqe==END_BQ_QUEUE);
 825       break;
 826
 827     case CONSTR:
 828       checkClosure((StgClosure *)bqe);
 829       end = rtsTrue;
 830       break;
 831
 832     default:
 833       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 834            get_itbl(bqe)->type, closure, info_type(closure));
 835     }
 836   } while (!end);
 837 }
 838 #elif defined(GRAN)
 839 void
 840 checkBQ (StgTSO *bqe, StgClosure *closure)
 841 {
 842   rtsBool end = rtsFalse;
 843   StgInfoTable *info = get_itbl(closure);
 844
 845   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 846
 847   do {
 848     switch (get_itbl(bqe)->type) {
 849     case BLOCKED_FETCH:
 850     case TSO:
 851       checkClosure((StgClosure *)bqe);
 852       bqe = bqe->link;
 853       end = (bqe==END_BQ_QUEUE);
 854       break;
 855
 856     default:
 857       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 858            get_itbl(bqe)->type, closure, info_type(closure));
 859     }
 860   } while (!end);
 861 }
 862 #else
 863 void
 864 checkBQ (StgTSO *bqe, StgClosure *closure)
 865 {
 866   rtsBool end = rtsFalse;
 867   StgInfoTable *info = get_itbl(closure);
 868
 869   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 870
 871   do {
 872     switch (get_itbl(bqe)->type) {
 873     case TSO:
 874       checkClosure((StgClosure *)bqe);
 875       bqe = bqe->link;
 876       end = (bqe==END_TSO_QUEUE);
 877       break;
 878
 879     default:
 880       barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
 881            get_itbl(bqe)->type, closure, info->type);
 882     }
 883   } while (!end);
 884 }
 885
 886 #endif
 887
 888
 889 //@node GALA table sanity, Index, Blackhole Sanity
 890 //@subsection GALA table sanity
 891
 892 /*
 893   This routine checks the sanity of the LAGA and GALA tables. They are
 894   implemented as lists through one hash table, LAtoGALAtable, because entries
 895   in both tables have the same structure:
 896    - the LAGA table maps local addresses to global addresses; it starts
 897      with liveIndirections
 898    - the GALA table maps global addresses to local addresses; it starts
 899      with liveRemoteGAs
 900 */
 901
 902 #if defined(PAR)
 903 #include "Hash.h"
 904
 905 /* hidden in parallel/Global.c; only accessed for testing here */
 906 extern GALA *liveIndirections;
 907 extern GALA *liveRemoteGAs;
 908 extern HashTable *LAtoGALAtable;
 909
 910 //@cindex checkLAGAtable
 911 void
 912 checkLAGAtable(rtsBool check_closures)
 913 {
 914   GALA *gala, *gala0;
 915   nat n=0, m=0; // debugging
 916
 917   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 918     n++;
 919     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 920     ASSERT(!gala->preferred || gala == gala0);
 921     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 922     ASSERT(gala->next!=gala); // detect direct loops
 923     /*
 924     if ( check_closures ) {
 925       checkClosure(stgCast(StgClosure*,gala->la));
 926     }
 927     */
 928   }
 929
 930   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 931     m++;
 932     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 933     ASSERT(!gala->preferred || gala == gala0);
 934     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 935     ASSERT(gala->next!=gala); // detect direct loops
 936     /*
 937     if ( check_closures ) {
 938       checkClosure(stgCast(StgClosure*,gala->la));
 939     }
 940     */
 941   }
 942 }
 943 #endif
 944
 945 //@node Index,  , GALA table sanity
 946 //@subsection Index
 947
 948 #endif /* DEBUG */
 949
 950 //@index
 951 //* checkBQ::  @cindex\s-+checkBQ
 952 //* checkChain::  @cindex\s-+checkChain
 953 //* checkClosureShallow::  @cindex\s-+checkClosureShallow
 954 //* checkHeap::  @cindex\s-+checkHeap
 955 //* checkLargeBitmap::  @cindex\s-+checkLargeBitmap
 956 //* checkSmallBitmap::  @cindex\s-+checkSmallBitmap
 957 //* checkStack::  @cindex\s-+checkStack
 958 //* checkStackChunk::  @cindex\s-+checkStackChunk
 959 //* checkStackChunk::  @cindex\s-+checkStackChunk
 960 //* checkStackClosure::  @cindex\s-+checkStackClosure
 961 //* checkStackObject::  @cindex\s-+checkStackObject
 962 //* checkTSO::  @cindex\s-+checkTSO
 963 //* checkTSOsSanity::  @cindex\s-+checkTSOsSanity
 964 //* checkThreadQSanity::  @cindex\s-+checkThreadQSanity
 965 //* checkThreadQsSanity::  @cindex\s-+checkThreadQsSanity
 966 //* isBlackhole::  @cindex\s-+isBlackhole
 967 //@end index