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