ghc/rts/Sanity.c

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