ghc/rts/Sanity.c

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