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