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 checkChain(bdescr *bd)
 637 {
 638   while (bd != NULL) {
 639     checkClosure((StgClosure *)bd->start);
 640     bd = bd->link;
 641   }
 642 }
 643
 644 void
 645 checkTSO(StgTSO *tso)
 646 {
 647     StgPtr sp = tso->sp;
 648     StgPtr stack = tso->stack;
 649     StgOffset stack_size = tso->stack_size;
 650     StgPtr stack_end = stack + stack_size;
 651
 652     if (tso->what_next == ThreadRelocated) {
 653       checkTSO(tso->_link);
 654       return;
 655     }
 656
 657     if (tso->what_next == ThreadKilled) {
 658       /* The garbage collector doesn't bother following any pointers
 659        * from dead threads, so don't check sanity here.
 660        */
 661       return;
 662     }
 663
 664     ASSERT(stack <= sp && sp < stack_end);
 665
 666 #if defined(PAR)
 667     ASSERT(tso->par.magic==TSO_MAGIC);
 668
 669     switch (tso->why_blocked) {
 670     case BlockedOnGA:
 671       checkClosureShallow(tso->block_info.closure);
 672       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 673              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 674       break;
 675     case BlockedOnGA_NoSend:
 676       checkClosureShallow(tso->block_info.closure);
 677       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 678       break;
 679     case BlockedOnBlackHole:
 680       checkClosureShallow(tso->block_info.closure);
 681       ASSERT(get_itbl(tso->block_info.closure)->type==BLACKHOLE ||
 682              get_itbl(tso->block_info.closure)->type==RBH);
 683       break;
 684     case BlockedOnRead:
 685     case BlockedOnWrite:
 686     case BlockedOnDelay:
 687 #if defined(mingw32_HOST_OS)
 688     case BlockedOnDoProc:
 689 #endif
 690       /* isOnBQ(blocked_queue) */
 691       break;
 692     case BlockedOnException:
 693       /* isOnSomeBQ(tso) */
 694       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 695       break;
 696     case BlockedOnMVar:
 697       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 698       break;
 699     case BlockedOnSTM:
 700       ASSERT(tso->block_info.closure == END_TSO_QUEUE);
 701       break;
 702     default:
 703       /*
 704          Could check other values of why_blocked but I am more
 705          lazy than paranoid (bad combination) -- HWL
 706       */
 707     }
 708
 709     /* if the link field is non-nil it most point to one of these
 710        three closure types */
 711     ASSERT(tso->link == END_TSO_QUEUE ||
 712            get_itbl(tso->link)->type == TSO ||
 713            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 714            get_itbl(tso->link)->type == CONSTR);
 715 #endif
 716
 717     checkStackChunk(sp, stack_end);
 718 }
 719
 720 #if defined(GRAN)
 721 void
 722 checkTSOsSanity(void) {
 723   nat i, tsos;
 724   StgTSO *tso;
 725
 726   debugBelch("Checking sanity of all runnable TSOs:");
 727
 728   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 729     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 730       debugBelch("TSO %p on PE %d ...", tso, i);
 731       checkTSO(tso);
 732       debugBelch("OK, ");
 733       tsos++;
 734     }
 735   }
 736
 737   debugBelch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 738 }
 739
 740
 741 // still GRAN only
 742
 743 rtsBool
 744 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 745 {
 746   StgTSO *tso, *prev;
 747
 748   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 749   ASSERT(run_queue_hds[proc]!=NULL);
 750   ASSERT(run_queue_tls[proc]!=NULL);
 751   /* if either head or tail is NIL then the other one must be NIL, too */
 752   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 753   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 754   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 755        tso!=END_TSO_QUEUE;
 756        prev=tso, tso=tso->link) {
 757     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 758            (prev==END_TSO_QUEUE || prev->link==tso));
 759     if (check_TSO_too)
 760       checkTSO(tso);
 761   }
 762   ASSERT(prev==run_queue_tls[proc]);
 763 }
 764
 765 rtsBool
 766 checkThreadQsSanity (rtsBool check_TSO_too)
 767 {
 768   PEs p;
 769
 770   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 771     checkThreadQSanity(p, check_TSO_too);
 772 }
 773 #endif /* GRAN */
 774
 775 /*
 776    Check that all TSOs have been evacuated.
 777    Optionally also check the sanity of the TSOs.
 778 */
 779 void
 780 checkGlobalTSOList (rtsBool checkTSOs)
 781 {
 782   StgTSO *tso;
 783   nat s;
 784
 785   for (s = 0; s < total_steps; s++) {
 786       for (tso=all_steps[s].threads; tso != END_TSO_QUEUE;
 787            tso = tso->global_link) {
 788           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
 789           ASSERT(get_itbl(tso)->type == TSO);
 790           if (checkTSOs)
 791               checkTSO(tso);
 792
 793           // If this TSO is dirty and in an old generation, it better
 794           // be on the mutable list.
 795           if (tso->what_next == ThreadRelocated) continue;
 796           if (tso->flags & (TSO_DIRTY|TSO_LINK_DIRTY)) {
 797               ASSERT(Bdescr((P_)tso)->gen_no == 0 || tso->flags & TSO_MARKED);
 798               tso->flags &= ~TSO_MARKED;
 799           }
 800       }
 801   }
 802 }
 803
 804 /* -----------------------------------------------------------------------------
 805    Check mutable list sanity.
 806    -------------------------------------------------------------------------- */
 807
 808 void
 809 checkMutableList( bdescr *mut_bd, nat gen )
 810 {
 811     bdescr *bd;
 812     StgPtr q;
 813     StgClosure *p;
 814
 815     for (bd = mut_bd; bd != NULL; bd = bd->link) {
 816         for (q = bd->start; q < bd->free; q++) {
 817             p = (StgClosure *)*q;
 818             ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
 819             if (get_itbl(p)->type == TSO) {
 820                 ((StgTSO *)p)->flags |= TSO_MARKED;
 821             }
 822         }
 823     }
 824 }
 825
 826 void
 827 checkMutableLists (void)
 828 {
 829     nat g, i;
 830
 831     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 832         checkMutableList(generations[g].mut_list, g);
 833         for (i = 0; i < n_capabilities; i++) {
 834             checkMutableList(capabilities[i].mut_lists[g], g);
 835         }
 836     }
 837     checkGlobalTSOList(rtsTrue);
 838 }
 839
 840 /*
 841   Check the static objects list.
 842 */
 843 void
 844 checkStaticObjects ( StgClosure* static_objects )
 845 {
 846   StgClosure *p = static_objects;
 847   StgInfoTable *info;
 848
 849   while (p != END_OF_STATIC_LIST) {
 850     checkClosure(p);
 851     info = get_itbl(p);
 852     switch (info->type) {
 853     case IND_STATIC:
 854       {
 855         StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
 856
 857         ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
 858         ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
 859         p = *IND_STATIC_LINK((StgClosure *)p);
 860         break;
 861       }
 862
 863     case THUNK_STATIC:
 864       p = *THUNK_STATIC_LINK((StgClosure *)p);
 865       break;
 866
 867     case FUN_STATIC:
 868       p = *FUN_STATIC_LINK((StgClosure *)p);
 869       break;
 870
 871     case CONSTR_STATIC:
 872       p = *STATIC_LINK(info,(StgClosure *)p);
 873       break;
 874
 875     default:
 876       barf("checkStaticObjetcs: strange closure %p (%s)",
 877            p, info_type(p));
 878     }
 879   }
 880 }
 881
 882 /*
 883    Check the sanity of a blocking queue starting at bqe with closure being
 884    the closure holding the blocking queue.
 885    Note that in GUM we can have several different closure types in a
 886    blocking queue
 887 */
 888 #if defined(PAR)
 889 void
 890 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 891 {
 892   rtsBool end = rtsFalse;
 893   StgInfoTable *info = get_itbl(closure);
 894
 895   ASSERT(info->type == MVAR || info->type == FETCH_ME_BQ || info->type == RBH);
 896
 897   do {
 898     switch (get_itbl(bqe)->type) {
 899     case BLOCKED_FETCH:
 900     case TSO:
 901       checkClosure((StgClosure *)bqe);
 902       bqe = bqe->link;
 903       end = (bqe==END_BQ_QUEUE);
 904       break;
 905
 906     case CONSTR:
 907       checkClosure((StgClosure *)bqe);
 908       end = rtsTrue;
 909       break;
 910
 911     default:
 912       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 913            get_itbl(bqe)->type, closure, info_type(closure));
 914     }
 915   } while (!end);
 916 }
 917 #elif defined(GRAN)
 918 void
 919 checkBQ (StgTSO *bqe, StgClosure *closure)
 920 {
 921   rtsBool end = rtsFalse;
 922   StgInfoTable *info = get_itbl(closure);
 923
 924   ASSERT(info->type == MVAR);
 925
 926   do {
 927     switch (get_itbl(bqe)->type) {
 928     case BLOCKED_FETCH:
 929     case TSO:
 930       checkClosure((StgClosure *)bqe);
 931       bqe = bqe->link;
 932       end = (bqe==END_BQ_QUEUE);
 933       break;
 934
 935     default:
 936       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 937            get_itbl(bqe)->type, closure, info_type(closure));
 938     }
 939   } while (!end);
 940 }
 941 #endif
 942
 943
 944
 945 /*
 946   This routine checks the sanity of the LAGA and GALA tables. They are
 947   implemented as lists through one hash table, LAtoGALAtable, because entries
 948   in both tables have the same structure:
 949    - the LAGA table maps local addresses to global addresses; it starts
 950      with liveIndirections
 951    - the GALA table maps global addresses to local addresses; it starts
 952      with liveRemoteGAs
 953 */
 954
 955 #if defined(PAR)
 956 #include "Hash.h"
 957
 958 /* hidden in parallel/Global.c; only accessed for testing here */
 959 extern GALA *liveIndirections;
 960 extern GALA *liveRemoteGAs;
 961 extern HashTable *LAtoGALAtable;
 962
 963 void
 964 checkLAGAtable(rtsBool check_closures)
 965 {
 966   GALA *gala, *gala0;
 967   nat n=0, m=0; // debugging
 968
 969   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 970     n++;
 971     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 972     ASSERT(!gala->preferred || gala == gala0);
 973     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 974     ASSERT(gala->next!=gala); // detect direct loops
 975     if ( check_closures ) {
 976       checkClosure((StgClosure *)gala->la);
 977     }
 978   }
 979
 980   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 981     m++;
 982     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 983     ASSERT(!gala->preferred || gala == gala0);
 984     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 985     ASSERT(gala->next!=gala); // detect direct loops
 986     /*
 987     if ( check_closures ) {
 988       checkClosure((StgClosure *)gala->la);
 989     }
 990     */
 991   }
 992 }
 993 #endif
 994
 995 #endif /* DEBUG */