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