ghc/rts/Sanity.c

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