rts/Sanity.c

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