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