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