rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2006
   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 thunk_sizeW_fromITBL(info);
 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 STABLE_NAME:
 308     case MUT_VAR_CLEAN:
 309     case MUT_VAR_DIRTY:
 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             StgInd *ind = (StgInd *)p;
 361             ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
 362             return sizeofW(StgInd);
 363         }
 364
 365     case RET_BCO:
 366     case RET_SMALL:
 367     case RET_VEC_SMALL:
 368     case RET_BIG:
 369     case RET_VEC_BIG:
 370     case RET_DYN:
 371     case UPDATE_FRAME:
 372     case STOP_FRAME:
 373     case CATCH_FRAME:
 374     case ATOMICALLY_FRAME:
 375     case CATCH_RETRY_FRAME:
 376     case CATCH_STM_FRAME:
 377             barf("checkClosure: stack frame");
 378
 379     case AP:
 380     {
 381         StgAP* ap = (StgAP *)p;
 382         checkPAP (ap->fun, ap->payload, ap->n_args);
 383         return ap_sizeW(ap);
 384     }
 385
 386     case PAP:
 387     {
 388         StgPAP* pap = (StgPAP *)p;
 389         checkPAP (pap->fun, pap->payload, pap->n_args);
 390         return pap_sizeW(pap);
 391     }
 392
 393     case AP_STACK:
 394     {
 395         StgAP_STACK *ap = (StgAP_STACK *)p;
 396         ASSERT(LOOKS_LIKE_CLOSURE_PTR(ap->fun));
 397         checkStackChunk((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
 398         return ap_stack_sizeW(ap);
 399     }
 400
 401     case ARR_WORDS:
 402             return arr_words_sizeW((StgArrWords *)p);
 403
 404     case MUT_ARR_PTRS_CLEAN:
 405     case MUT_ARR_PTRS_DIRTY:
 406     case MUT_ARR_PTRS_FROZEN:
 407     case MUT_ARR_PTRS_FROZEN0:
 408         {
 409             StgMutArrPtrs* a = (StgMutArrPtrs *)p;
 410             nat i;
 411             for (i = 0; i < a->ptrs; i++) {
 412                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
 413             }
 414             return mut_arr_ptrs_sizeW(a);
 415         }
 416
 417     case TSO:
 418         checkTSO((StgTSO *)p);
 419         return tso_sizeW((StgTSO *)p);
 420
 421 #if defined(PAR)
 422
 423     case BLOCKED_FETCH:
 424       ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
 425       ASSERT(LOOKS_LIKE_CLOSURE_PTR((((StgBlockedFetch *)p)->node)));
 426       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 427
 428 #ifdef DIST
 429     case REMOTE_REF:
 430       return sizeofW(StgFetchMe);
 431 #endif /*DIST */
 432
 433     case FETCH_ME:
 434       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 435       return sizeofW(StgFetchMe);  // see size used in evacuate()
 436
 437     case FETCH_ME_BQ:
 438       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 439       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 440
 441     case RBH:
 442       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 443       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 444       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 445         checkBQ(((StgRBH *)p)->blocking_queue, p);
 446       ASSERT(LOOKS_LIKE_INFO_PTR(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 447       return BLACKHOLE_sizeW();   // see size used in evacuate()
 448       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 449
 450 #endif
 451
 452     case TVAR_WAIT_QUEUE:
 453       {
 454         StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
 455         ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->next_queue_entry));
 456         ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->prev_queue_entry));
 457         return sizeofW(StgTVarWaitQueue);
 458       }
 459
 460     case TVAR:
 461       {
 462         StgTVar *tv = (StgTVar *)p;
 463         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->current_value));
 464         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->first_wait_queue_entry));
 465         return sizeofW(StgTVar);
 466       }
 467
 468     case TREC_CHUNK:
 469       {
 470         nat i;
 471         StgTRecChunk *tc = (StgTRecChunk *)p;
 472         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->prev_chunk));
 473         for (i = 0; i < tc -> next_entry_idx; i ++) {
 474           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].tvar));
 475           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].expected_value));
 476           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].new_value));
 477         }
 478         return sizeofW(StgTRecChunk);
 479       }
 480
 481     case TREC_HEADER:
 482       {
 483         StgTRecHeader *trec = (StgTRecHeader *)p;
 484         ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> enclosing_trec));
 485         ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> current_chunk));
 486         return sizeofW(StgTRecHeader);
 487       }
 488
 489
 490     case EVACUATED:
 491             barf("checkClosure: found EVACUATED closure %d",
 492                  info->type);
 493     default:
 494             barf("checkClosure (closure type %d)", info->type);
 495     }
 496 }
 497
 498 #if defined(PAR)
 499
 500 #define PVM_PE_MASK    0xfffc0000
 501 #define MAX_PVM_PES    MAX_PES
 502 #define MAX_PVM_TIDS   MAX_PES
 503 #define MAX_SLOTS      100000
 504
 505 rtsBool
 506 looks_like_tid(StgInt tid)
 507 {
 508   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 509   StgInt lo = (tid & ~PVM_PE_MASK);
 510   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 511   return ok;
 512 }
 513
 514 rtsBool
 515 looks_like_slot(StgInt slot)
 516 {
 517   /* if tid is known better use looks_like_ga!! */
 518   rtsBool ok = slot<MAX_SLOTS;
 519   // This refers only to the no. of slots on the current PE
 520   // rtsBool ok = slot<=highest_slot();
 521   return ok;
 522 }
 523
 524 rtsBool
 525 looks_like_ga(globalAddr *ga)
 526 {
 527   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 528   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 529                      (ga)->payload.gc.slot<=highest_slot() :
 530                      (ga)->payload.gc.slot<MAX_SLOTS;
 531   rtsBool ok = is_tid && is_slot;
 532   return ok;
 533 }
 534
 535 #endif
 536
 537
 538 /* -----------------------------------------------------------------------------
 539    Check Heap Sanity
 540
 541    After garbage collection, the live heap is in a state where we can
 542    run through and check that all the pointers point to the right
 543    place.  This function starts at a given position and sanity-checks
 544    all the objects in the remainder of the chain.
 545    -------------------------------------------------------------------------- */
 546
 547 void
 548 checkHeap(bdescr *bd)
 549 {
 550     StgPtr p;
 551
 552 #if defined(THREADED_RTS)
 553     // heap sanity checking doesn't work with SMP, because we can't
 554     // zero the slop (see Updates.h).
 555     return;
 556 #endif
 557
 558     for (; bd != NULL; bd = bd->link) {
 559         p = bd->start;
 560         while (p < bd->free) {
 561             nat size = checkClosure((StgClosure *)p);
 562             /* This is the smallest size of closure that can live in the heap */
 563             ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
 564             p += size;
 565
 566             /* skip over slop */
 567             while (p < bd->free &&
 568                    (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR((void*)*p))) { p++; }
 569         }
 570     }
 571 }
 572
 573 #if defined(PAR)
 574 /*
 575    Check heap between start and end. Used after unpacking graphs.
 576 */
 577 void
 578 checkHeapChunk(StgPtr start, StgPtr end)
 579 {
 580   extern globalAddr *LAGAlookup(StgClosure *addr);
 581   StgPtr p;
 582   nat size;
 583
 584   for (p=start; p<end; p+=size) {
 585     ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
 586     if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
 587         *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
 588       /* if it's a FM created during unpack and commoned up, it's not global */
 589       ASSERT(LAGAlookup((StgClosure*)p)==NULL);
 590       size = sizeofW(StgFetchMe);
 591     } else if (get_itbl((StgClosure*)p)->type == IND) {
 592       *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
 593       size = sizeofW(StgInd);
 594     } else {
 595       size = checkClosure((StgClosure *)p);
 596       /* This is the smallest size of closure that can live in the heap. */
 597       ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
 598     }
 599   }
 600 }
 601 #else /* !PAR */
 602 void
 603 checkHeapChunk(StgPtr start, StgPtr end)
 604 {
 605   StgPtr p;
 606   nat size;
 607
 608   for (p=start; p<end; p+=size) {
 609     ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
 610     size = checkClosure((StgClosure *)p);
 611     /* This is the smallest size of closure that can live in the heap. */
 612     ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
 613   }
 614 }
 615 #endif
 616
 617 void
 618 checkChain(bdescr *bd)
 619 {
 620   while (bd != NULL) {
 621     checkClosure((StgClosure *)bd->start);
 622     bd = bd->link;
 623   }
 624 }
 625
 626 void
 627 checkTSO(StgTSO *tso)
 628 {
 629     StgPtr sp = tso->sp;
 630     StgPtr stack = tso->stack;
 631     StgOffset stack_size = tso->stack_size;
 632     StgPtr stack_end = stack + stack_size;
 633
 634     if (tso->what_next == ThreadRelocated) {
 635       checkTSO(tso->link);
 636       return;
 637     }
 638
 639     if (tso->what_next == ThreadKilled) {
 640       /* The garbage collector doesn't bother following any pointers
 641        * from dead threads, so don't check sanity here.
 642        */
 643       return;
 644     }
 645
 646     ASSERT(stack <= sp && sp < stack_end);
 647
 648 #if defined(PAR)
 649     ASSERT(tso->par.magic==TSO_MAGIC);
 650
 651     switch (tso->why_blocked) {
 652     case BlockedOnGA:
 653       checkClosureShallow(tso->block_info.closure);
 654       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 655              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 656       break;
 657     case BlockedOnGA_NoSend:
 658       checkClosureShallow(tso->block_info.closure);
 659       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 660       break;
 661     case BlockedOnBlackHole:
 662       checkClosureShallow(tso->block_info.closure);
 663       ASSERT(get_itbl(tso->block_info.closure)->type==BLACKHOLE ||
 664              get_itbl(tso->block_info.closure)->type==RBH);
 665       break;
 666     case BlockedOnRead:
 667     case BlockedOnWrite:
 668     case BlockedOnDelay:
 669 #if defined(mingw32_HOST_OS)
 670     case BlockedOnDoProc:
 671 #endif
 672       /* isOnBQ(blocked_queue) */
 673       break;
 674     case BlockedOnException:
 675       /* isOnSomeBQ(tso) */
 676       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 677       break;
 678     case BlockedOnMVar:
 679       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 680       break;
 681     case BlockedOnSTM:
 682       ASSERT(tso->block_info.closure == END_TSO_QUEUE);
 683       break;
 684     default:
 685       /*
 686          Could check other values of why_blocked but I am more
 687          lazy than paranoid (bad combination) -- HWL
 688       */
 689     }
 690
 691     /* if the link field is non-nil it most point to one of these
 692        three closure types */
 693     ASSERT(tso->link == END_TSO_QUEUE ||
 694            get_itbl(tso->link)->type == TSO ||
 695            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 696            get_itbl(tso->link)->type == CONSTR);
 697 #endif
 698
 699     checkStackChunk(sp, stack_end);
 700 }
 701
 702 #if defined(GRAN)
 703 void
 704 checkTSOsSanity(void) {
 705   nat i, tsos;
 706   StgTSO *tso;
 707
 708   debugBelch("Checking sanity of all runnable TSOs:");
 709
 710   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 711     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 712       debugBelch("TSO %p on PE %d ...", tso, i);
 713       checkTSO(tso);
 714       debugBelch("OK, ");
 715       tsos++;
 716     }
 717   }
 718
 719   debugBelch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 720 }
 721
 722
 723 // still GRAN only
 724
 725 rtsBool
 726 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 727 {
 728   StgTSO *tso, *prev;
 729
 730   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 731   ASSERT(run_queue_hds[proc]!=NULL);
 732   ASSERT(run_queue_tls[proc]!=NULL);
 733   /* if either head or tail is NIL then the other one must be NIL, too */
 734   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 735   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 736   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 737        tso!=END_TSO_QUEUE;
 738        prev=tso, tso=tso->link) {
 739     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 740            (prev==END_TSO_QUEUE || prev->link==tso));
 741     if (check_TSO_too)
 742       checkTSO(tso);
 743   }
 744   ASSERT(prev==run_queue_tls[proc]);
 745 }
 746
 747 rtsBool
 748 checkThreadQsSanity (rtsBool check_TSO_too)
 749 {
 750   PEs p;
 751
 752   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 753     checkThreadQSanity(p, check_TSO_too);
 754 }
 755 #endif /* GRAN */
 756
 757 /*
 758    Check that all TSOs have been evacuated.
 759    Optionally also check the sanity of the TSOs.
 760 */
 761 void
 762 checkGlobalTSOList (rtsBool checkTSOs)
 763 {
 764   extern  StgTSO *all_threads;
 765   StgTSO *tso;
 766   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 767       ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
 768       ASSERT(get_itbl(tso)->type == TSO);
 769       if (checkTSOs)
 770           checkTSO(tso);
 771   }
 772 }
 773
 774 /* -----------------------------------------------------------------------------
 775    Check mutable list sanity.
 776    -------------------------------------------------------------------------- */
 777
 778 void
 779 checkMutableList( bdescr *mut_bd, nat gen )
 780 {
 781     bdescr *bd;
 782     StgPtr q;
 783     StgClosure *p;
 784
 785     for (bd = mut_bd; bd != NULL; bd = bd->link) {
 786         for (q = bd->start; q < bd->free; q++) {
 787             p = (StgClosure *)*q;
 788             ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
 789         }
 790     }
 791 }
 792
 793 /*
 794   Check the static objects list.
 795 */
 796 void
 797 checkStaticObjects ( StgClosure* static_objects )
 798 {
 799   StgClosure *p = static_objects;
 800   StgInfoTable *info;
 801
 802   while (p != END_OF_STATIC_LIST) {
 803     checkClosure(p);
 804     info = get_itbl(p);
 805     switch (info->type) {
 806     case IND_STATIC:
 807       {
 808         StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
 809
 810         ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
 811         ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
 812         p = *IND_STATIC_LINK((StgClosure *)p);
 813         break;
 814       }
 815
 816     case THUNK_STATIC:
 817       p = *THUNK_STATIC_LINK((StgClosure *)p);
 818       break;
 819
 820     case FUN_STATIC:
 821       p = *FUN_STATIC_LINK((StgClosure *)p);
 822       break;
 823
 824     case CONSTR_STATIC:
 825       p = *STATIC_LINK(info,(StgClosure *)p);
 826       break;
 827
 828     default:
 829       barf("checkStaticObjetcs: strange closure %p (%s)",
 830            p, info_type(p));
 831     }
 832   }
 833 }
 834
 835 /*
 836    Check the sanity of a blocking queue starting at bqe with closure being
 837    the closure holding the blocking queue.
 838    Note that in GUM we can have several different closure types in a
 839    blocking queue
 840 */
 841 #if defined(PAR)
 842 void
 843 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 844 {
 845   rtsBool end = rtsFalse;
 846   StgInfoTable *info = get_itbl(closure);
 847
 848   ASSERT(info->type == MVAR || info->type == FETCH_ME_BQ || info->type == RBH);
 849
 850   do {
 851     switch (get_itbl(bqe)->type) {
 852     case BLOCKED_FETCH:
 853     case TSO:
 854       checkClosure((StgClosure *)bqe);
 855       bqe = bqe->link;
 856       end = (bqe==END_BQ_QUEUE);
 857       break;
 858
 859     case CONSTR:
 860       checkClosure((StgClosure *)bqe);
 861       end = rtsTrue;
 862       break;
 863
 864     default:
 865       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 866            get_itbl(bqe)->type, closure, info_type(closure));
 867     }
 868   } while (!end);
 869 }
 870 #elif defined(GRAN)
 871 void
 872 checkBQ (StgTSO *bqe, StgClosure *closure)
 873 {
 874   rtsBool end = rtsFalse;
 875   StgInfoTable *info = get_itbl(closure);
 876
 877   ASSERT(info->type == MVAR);
 878
 879   do {
 880     switch (get_itbl(bqe)->type) {
 881     case BLOCKED_FETCH:
 882     case TSO:
 883       checkClosure((StgClosure *)bqe);
 884       bqe = bqe->link;
 885       end = (bqe==END_BQ_QUEUE);
 886       break;
 887
 888     default:
 889       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 890            get_itbl(bqe)->type, closure, info_type(closure));
 891     }
 892   } while (!end);
 893 }
 894 #endif
 895
 896
 897
 898 /*
 899   This routine checks the sanity of the LAGA and GALA tables. They are
 900   implemented as lists through one hash table, LAtoGALAtable, because entries
 901   in both tables have the same structure:
 902    - the LAGA table maps local addresses to global addresses; it starts
 903      with liveIndirections
 904    - the GALA table maps global addresses to local addresses; it starts
 905      with liveRemoteGAs
 906 */
 907
 908 #if defined(PAR)
 909 #include "Hash.h"
 910
 911 /* hidden in parallel/Global.c; only accessed for testing here */
 912 extern GALA *liveIndirections;
 913 extern GALA *liveRemoteGAs;
 914 extern HashTable *LAtoGALAtable;
 915
 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_INFO_PTR(((StgClosure *)gala->la)->header.info));
 927     ASSERT(gala->next!=gala); // detect direct loops
 928     if ( check_closures ) {
 929       checkClosure((StgClosure *)gala->la);
 930     }
 931   }
 932
 933   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 934     m++;
 935     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 936     ASSERT(!gala->preferred || gala == gala0);
 937     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 938     ASSERT(gala->next!=gala); // detect direct loops
 939     /*
 940     if ( check_closures ) {
 941       checkClosure((StgClosure *)gala->la);
 942     }
 943     */
 944   }
 945 }
 946 #endif
 947
 948 #endif /* DEBUG */