ghc/rts/Sanity.c

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