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