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