ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.34 2003/07/03 15:14:58 sof Exp $
   3  *
   4  * (c) The GHC Team, 1998-2001
   5  *
   6  * Sanity checking code for the heap and stack.
   7  *
   8  * Used when debugging: check that everything reasonable.
   9  *
  10  *    - All things that are supposed to be pointers look like pointers.
  11  *
  12  *    - Objects in text space are marked as static closures, those
  13  *      in the heap are dynamic.
  14  *
  15  * ---------------------------------------------------------------------------*/
  16
  17 #include "PosixSource.h"
  18 #include "Rts.h"
  19
  20 #ifdef DEBUG                                                   /* whole file */
  21
  22 #include "RtsFlags.h"
  23 #include "RtsUtils.h"
  24 #include "BlockAlloc.h"
  25 #include "Sanity.h"
  26 #include "MBlock.h"
  27 #include "Storage.h"
  28 #include "Schedule.h"
  29 #include "StoragePriv.h"   // for END_OF_STATIC_LIST
  30 #include "Apply.h"
  31
  32 /* -----------------------------------------------------------------------------
  33    Forward decls.
  34    -------------------------------------------------------------------------- */
  35
  36 static void      checkSmallBitmap    ( StgPtr payload, StgWord bitmap, nat );
  37 static void      checkLargeBitmap    ( StgPtr payload, StgLargeBitmap*, nat );
  38 static void      checkClosureShallow ( StgClosure * );
  39
  40 /* -----------------------------------------------------------------------------
  41    Check stack sanity
  42    -------------------------------------------------------------------------- */
  43
  44 static void
  45 checkSmallBitmap( StgPtr payload, StgWord bitmap, nat size )
  46 {
  47     StgPtr p;
  48     nat i;
  49
  50     p = payload;
  51     for(i = 0; i < size; i++, bitmap >>= 1 ) {
  52         if ((bitmap & 1) == 0) {
  53             checkClosureShallow((StgClosure *)payload[i]);
  54         }
  55     }
  56 }
  57
  58 static void
  59 checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
  60 {
  61     StgWord bmp;
  62     nat i, j;
  63
  64     i = 0;
  65     for (bmp=0; i < size; bmp++) {
  66         StgWord bitmap = large_bitmap->bitmap[bmp];
  67         j = 0;
  68         for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
  69             if ((bitmap & 1) == 0) {
  70                 checkClosureShallow((StgClosure *)payload[i]);
  71             }
  72         }
  73     }
  74 }
  75
  76 /*
  77  * check that it looks like a valid closure - without checking its payload
  78  * used to avoid recursion between checking PAPs and checking stack
  79  * chunks.
  80  */
  81
  82 static void
  83 checkClosureShallow( StgClosure* p )
  84 {
  85     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
  86
  87     /* Is it a static closure? */
  88     if (!HEAP_ALLOCED(p)) {
  89         ASSERT(closure_STATIC(p));
  90     } else {
  91         ASSERT(!closure_STATIC(p));
  92     }
  93 }
  94
  95 // check an individual stack object
  96 StgOffset
  97 checkStackFrame( StgPtr c )
  98 {
  99     nat size;
 100     const StgRetInfoTable* info;
 101
 102     info = get_ret_itbl((StgClosure *)c);
 103
 104     /* All activation records have 'bitmap' style layout info. */
 105     switch (info->i.type) {
 106     case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
 107     {
 108         StgWord dyn;
 109         StgPtr p;
 110         StgRetDyn* r;
 111
 112         r = (StgRetDyn *)c;
 113         dyn = r->liveness;
 114
 115         p = (P_)(r->payload);
 116         checkSmallBitmap(p,GET_LIVENESS(r->liveness),RET_DYN_BITMAP_SIZE);
 117         p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
 118
 119         // skip over the non-pointers
 120         p += GET_NONPTRS(dyn);
 121
 122         // follow the ptr words
 123         for (size = GET_PTRS(dyn); size > 0; size--) {
 124             checkClosureShallow((StgClosure *)*p);
 125             p++;
 126         }
 127
 128         return sizeofW(StgRetDyn) + RET_DYN_BITMAP_SIZE +
 129             RET_DYN_NONPTR_REGS_SIZE +
 130             GET_NONPTRS(dyn) + GET_PTRS(dyn);
 131     }
 132
 133     case UPDATE_FRAME:
 134       ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgUpdateFrame*)c)->updatee));
 135     case CATCH_FRAME:
 136       // small bitmap cases (<= 32 entries)
 137     case STOP_FRAME:
 138     case RET_SMALL:
 139     case RET_VEC_SMALL:
 140         size = BITMAP_SIZE(info->i.layout.bitmap);
 141         checkSmallBitmap((StgPtr)c + 1,
 142                          BITMAP_BITS(info->i.layout.bitmap), size);
 143         return 1 + size;
 144
 145     case RET_BCO: {
 146         StgBCO *bco;
 147         nat size;
 148         bco = (StgBCO *)*(c+1);
 149         size = BCO_BITMAP_SIZE(bco);
 150         checkLargeBitmap((StgPtr)c + 2, BCO_BITMAP(bco), size);
 151         return 2 + size;
 152     }
 153
 154     case RET_BIG: // large bitmap (> 32 entries)
 155     case RET_VEC_BIG:
 156         size = info->i.layout.large_bitmap->size;
 157         checkLargeBitmap((StgPtr)c + 1, info->i.layout.large_bitmap, size);
 158         return 1 + size;
 159
 160     case RET_FUN:
 161     {
 162         StgFunInfoTable *fun_info;
 163         StgRetFun *ret_fun;
 164
 165         ret_fun = (StgRetFun *)c;
 166         fun_info = get_fun_itbl(ret_fun->fun);
 167         size = ret_fun->size;
 168         switch (fun_info->fun_type) {
 169         case ARG_GEN:
 170             checkSmallBitmap((StgPtr)ret_fun->payload,
 171                              BITMAP_BITS(fun_info->bitmap), size);
 172             break;
 173         case ARG_GEN_BIG:
 174             checkLargeBitmap((StgPtr)ret_fun->payload,
 175                              (StgLargeBitmap *)fun_info->bitmap, size);
 176             break;
 177         default:
 178             checkSmallBitmap((StgPtr)ret_fun->payload,
 179                              BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]),
 180                              size);
 181             break;
 182         }
 183         return sizeofW(StgRetFun) + size;
 184     }
 185
 186     default:
 187         barf("checkStackFrame: weird activation record found on stack (%p).",c);
 188     }
 189 }
 190
 191 // check sections of stack between update frames
 192 void
 193 checkStackChunk( StgPtr sp, StgPtr stack_end )
 194 {
 195     StgPtr p;
 196
 197     p = sp;
 198     while (p < stack_end) {
 199         p += checkStackFrame( p );
 200     }
 201     // ASSERT( p == stack_end ); -- HWL
 202 }
 203
 204 StgOffset
 205 checkClosure( StgClosure* p )
 206 {
 207     const StgInfoTable *info;
 208
 209     ASSERT(LOOKS_LIKE_INFO_PTR(p->header.info));
 210
 211     /* Is it a static closure (i.e. in the data segment)? */
 212     if (!HEAP_ALLOCED(p)) {
 213         ASSERT(closure_STATIC(p));
 214     } else {
 215         ASSERT(!closure_STATIC(p));
 216     }
 217
 218     info = get_itbl(p);
 219     switch (info->type) {
 220
 221     case MVAR:
 222       {
 223         StgMVar *mvar = (StgMVar *)p;
 224         ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
 225         ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail));
 226         ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value));
 227 #if 0
 228 #if defined(PAR)
 229         checkBQ((StgBlockingQueueElement *)mvar->head, p);
 230 #else
 231         checkBQ(mvar->head, p);
 232 #endif
 233 #endif
 234         return sizeofW(StgMVar);
 235       }
 236
 237     case THUNK:
 238     case THUNK_1_0:
 239     case THUNK_0_1:
 240     case THUNK_1_1:
 241     case THUNK_0_2:
 242     case THUNK_2_0:
 243       {
 244         nat i;
 245         for (i = 0; i < info->layout.payload.ptrs; i++) {
 246           ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
 247         }
 248         return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
 249       }
 250
 251     case BLACKHOLE_BQ:
 252       checkBQ(((StgBlockingQueue *)p)->blocking_queue, p);
 253       /* fall through to basic ptr check */
 254     case FUN:
 255     case FUN_1_0:
 256     case FUN_0_1:
 257     case FUN_1_1:
 258     case FUN_0_2:
 259     case FUN_2_0:
 260     case CONSTR:
 261     case CONSTR_1_0:
 262     case CONSTR_0_1:
 263     case CONSTR_1_1:
 264     case CONSTR_0_2:
 265     case CONSTR_2_0:
 266     case IND_PERM:
 267     case IND_OLDGEN:
 268     case IND_OLDGEN_PERM:
 269 #ifdef TICKY_TICKY
 270     case SE_BLACKHOLE:
 271     case SE_CAF_BLACKHOLE:
 272 #endif
 273     case BLACKHOLE:
 274     case CAF_BLACKHOLE:
 275     case FOREIGN:
 276     case STABLE_NAME:
 277     case MUT_VAR:
 278     case MUT_CONS:
 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 sizeofW(StgHeader) + MIN_UPD_SIZE;
 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             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->fun_type) {
 359             case ARG_GEN:
 360                 checkSmallBitmap( (StgPtr)pap->payload,
 361                                   BITMAP_BITS(fun_info->bitmap), pap->n_args );
 362                 break;
 363             case ARG_GEN_BIG:
 364                 checkLargeBitmap( (StgPtr)pap->payload,
 365                                   (StgLargeBitmap *)fun_info->bitmap,
 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->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         {
 396             StgMutArrPtrs* a = (StgMutArrPtrs *)p;
 397             nat i;
 398             for (i = 0; i < a->ptrs; i++) {
 399                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
 400             }
 401             return mut_arr_ptrs_sizeW(a);
 402         }
 403
 404     case TSO:
 405         checkTSO((StgTSO *)p);
 406         return tso_sizeW((StgTSO *)p);
 407
 408 #if defined(PAR)
 409
 410     case BLOCKED_FETCH:
 411       ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
 412       ASSERT(LOOKS_LIKE_CLOSURE_PTR((((StgBlockedFetch *)p)->node)));
 413       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 414
 415 #ifdef DIST
 416     case REMOTE_REF:
 417       return sizeofW(StgFetchMe);
 418 #endif //DIST
 419
 420     case FETCH_ME:
 421       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 422       return sizeofW(StgFetchMe);  // see size used in evacuate()
 423
 424     case FETCH_ME_BQ:
 425       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 426       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 427
 428     case RBH:
 429       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 430       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 431       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 432         checkBQ(((StgRBH *)p)->blocking_queue, p);
 433       ASSERT(LOOKS_LIKE_INFO_PTR(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 434       return BLACKHOLE_sizeW();   // see size used in evacuate()
 435       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 436
 437 #endif
 438
 439     case EVACUATED:
 440             barf("checkClosure: found EVACUATED closure %d",
 441                  info->type);
 442     default:
 443             barf("checkClosure (closure type %d)", info->type);
 444     }
 445 }
 446
 447 #if defined(PAR)
 448
 449 #define PVM_PE_MASK    0xfffc0000
 450 #define MAX_PVM_PES    MAX_PES
 451 #define MAX_PVM_TIDS   MAX_PES
 452 #define MAX_SLOTS      100000
 453
 454 rtsBool
 455 looks_like_tid(StgInt tid)
 456 {
 457   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 458   StgInt lo = (tid & ~PVM_PE_MASK);
 459   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 460   return ok;
 461 }
 462
 463 rtsBool
 464 looks_like_slot(StgInt slot)
 465 {
 466   /* if tid is known better use looks_like_ga!! */
 467   rtsBool ok = slot<MAX_SLOTS;
 468   // This refers only to the no. of slots on the current PE
 469   // rtsBool ok = slot<=highest_slot();
 470   return ok;
 471 }
 472
 473 rtsBool
 474 looks_like_ga(globalAddr *ga)
 475 {
 476   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 477   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 478                      (ga)->payload.gc.slot<=highest_slot() :
 479                      (ga)->payload.gc.slot<MAX_SLOTS;
 480   rtsBool ok = is_tid && is_slot;
 481   return ok;
 482 }
 483
 484 #endif
 485
 486
 487 /* -----------------------------------------------------------------------------
 488    Check Heap Sanity
 489
 490    After garbage collection, the live heap is in a state where we can
 491    run through and check that all the pointers point to the right
 492    place.  This function starts at a given position and sanity-checks
 493    all the objects in the remainder of the chain.
 494    -------------------------------------------------------------------------- */
 495
 496 void
 497 checkHeap(bdescr *bd)
 498 {
 499     StgPtr p;
 500
 501     for (; bd != NULL; bd = bd->link) {
 502         p = bd->start;
 503         while (p < bd->free) {
 504             nat size = checkClosure((StgClosure *)p);
 505             /* This is the smallest size of closure that can live in the heap */
 506             ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 507             p += size;
 508
 509             /* skip over slop */
 510             while (p < bd->free &&
 511                    (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR((void*)*p))) { p++; }
 512         }
 513     }
 514 }
 515
 516 #if defined(PAR)
 517 /*
 518    Check heap between start and end. Used after unpacking graphs.
 519 */
 520 void
 521 checkHeapChunk(StgPtr start, StgPtr end)
 522 {
 523   extern globalAddr *LAGAlookup(StgClosure *addr);
 524   StgPtr p;
 525   nat size;
 526
 527   for (p=start; p<end; p+=size) {
 528     ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
 529     if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
 530         *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
 531       /* if it's a FM created during unpack and commoned up, it's not global */
 532       ASSERT(LAGAlookup((StgClosure*)p)==NULL);
 533       size = sizeofW(StgFetchMe);
 534     } else if (get_itbl((StgClosure*)p)->type == IND) {
 535       *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
 536       size = MIN_UPD_SIZE;
 537     } else {
 538       size = checkClosure((StgClosure *)p);
 539       /* This is the smallest size of closure that can live in the heap. */
 540       ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 541     }
 542   }
 543 }
 544 #else /* !PAR */
 545 void
 546 checkHeapChunk(StgPtr start, StgPtr end)
 547 {
 548   StgPtr p;
 549   nat size;
 550
 551   for (p=start; p<end; p+=size) {
 552     ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
 553     size = checkClosure((StgClosure *)p);
 554     /* This is the smallest size of closure that can live in the heap. */
 555     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 556   }
 557 }
 558 #endif
 559
 560 void
 561 checkChain(bdescr *bd)
 562 {
 563   while (bd != NULL) {
 564     checkClosure((StgClosure *)bd->start);
 565     bd = bd->link;
 566   }
 567 }
 568
 569 void
 570 checkTSO(StgTSO *tso)
 571 {
 572     StgPtr sp = tso->sp;
 573     StgPtr stack = tso->stack;
 574     StgOffset stack_size = tso->stack_size;
 575     StgPtr stack_end = stack + stack_size;
 576
 577     if (tso->what_next == ThreadRelocated) {
 578       checkTSO(tso->link);
 579       return;
 580     }
 581
 582     if (tso->what_next == ThreadKilled) {
 583       /* The garbage collector doesn't bother following any pointers
 584        * from dead threads, so don't check sanity here.
 585        */
 586       return;
 587     }
 588
 589     ASSERT(stack <= sp && sp < stack_end);
 590
 591 #if defined(PAR)
 592     ASSERT(tso->par.magic==TSO_MAGIC);
 593
 594     switch (tso->why_blocked) {
 595     case BlockedOnGA:
 596       checkClosureShallow(tso->block_info.closure);
 597       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 598              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 599       break;
 600     case BlockedOnGA_NoSend:
 601       checkClosureShallow(tso->block_info.closure);
 602       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 603       break;
 604     case BlockedOnBlackHole:
 605       checkClosureShallow(tso->block_info.closure);
 606       ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
 607              get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
 608              get_itbl(tso->block_info.closure)->type==RBH);
 609       break;
 610     case BlockedOnRead:
 611     case BlockedOnWrite:
 612     case BlockedOnDelay:
 613 #if defined(mingw32_TARGET_OS)
 614     case BlockedOnDoProc:
 615 #endif
 616       /* isOnBQ(blocked_queue) */
 617       break;
 618     case BlockedOnException:
 619       /* isOnSomeBQ(tso) */
 620       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 621       break;
 622     case BlockedOnMVar:
 623       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 624       break;
 625     default:
 626       /*
 627          Could check other values of why_blocked but I am more
 628          lazy than paranoid (bad combination) -- HWL
 629       */
 630     }
 631
 632     /* if the link field is non-nil it most point to one of these
 633        three closure types */
 634     ASSERT(tso->link == END_TSO_QUEUE ||
 635            get_itbl(tso->link)->type == TSO ||
 636            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 637            get_itbl(tso->link)->type == CONSTR);
 638 #endif
 639
 640     checkStackChunk(sp, stack_end);
 641 }
 642
 643 #if defined(GRAN)
 644 void
 645 checkTSOsSanity(void) {
 646   nat i, tsos;
 647   StgTSO *tso;
 648
 649   belch("Checking sanity of all runnable TSOs:");
 650
 651   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 652     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 653       fprintf(stderr, "TSO %p on PE %d ...", tso, i);
 654       checkTSO(tso);
 655       fprintf(stderr, "OK, ");
 656       tsos++;
 657     }
 658   }
 659
 660   belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 661 }
 662
 663
 664 // still GRAN only
 665
 666 rtsBool
 667 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 668 {
 669   StgTSO *tso, *prev;
 670
 671   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 672   ASSERT(run_queue_hds[proc]!=NULL);
 673   ASSERT(run_queue_tls[proc]!=NULL);
 674   /* if either head or tail is NIL then the other one must be NIL, too */
 675   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 676   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 677   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 678        tso!=END_TSO_QUEUE;
 679        prev=tso, tso=tso->link) {
 680     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 681            (prev==END_TSO_QUEUE || prev->link==tso));
 682     if (check_TSO_too)
 683       checkTSO(tso);
 684   }
 685   ASSERT(prev==run_queue_tls[proc]);
 686 }
 687
 688 rtsBool
 689 checkThreadQsSanity (rtsBool check_TSO_too)
 690 {
 691   PEs p;
 692
 693   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 694     checkThreadQSanity(p, check_TSO_too);
 695 }
 696 #endif /* GRAN */
 697
 698 /*
 699    Check that all TSOs have been evacuated.
 700    Optionally also check the sanity of the TSOs.
 701 */
 702 void
 703 checkGlobalTSOList (rtsBool checkTSOs)
 704 {
 705   extern  StgTSO *all_threads;
 706   StgTSO *tso;
 707   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 708       ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
 709       ASSERT(get_itbl(tso)->type == TSO);
 710       if (checkTSOs)
 711           checkTSO(tso);
 712   }
 713 }
 714
 715 /* -----------------------------------------------------------------------------
 716    Check mutable list sanity.
 717    -------------------------------------------------------------------------- */
 718
 719 void
 720 checkMutableList( StgMutClosure *p, nat gen )
 721 {
 722     bdescr *bd;
 723
 724     for (; p != END_MUT_LIST; p = p->mut_link) {
 725         bd = Bdescr((P_)p);
 726         ASSERT(closure_MUTABLE(p));
 727         ASSERT(bd->gen_no == gen);
 728         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
 729     }
 730 }
 731
 732 void
 733 checkMutOnceList( StgMutClosure *p, nat gen )
 734 {
 735     bdescr *bd;
 736     StgInfoTable *info;
 737
 738     for (; p != END_MUT_LIST; p = p->mut_link) {
 739         bd = Bdescr((P_)p);
 740         info = get_itbl(p);
 741
 742         ASSERT(!closure_MUTABLE(p));
 743         ASSERT(ip_STATIC(info) || bd->gen_no == gen);
 744         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
 745
 746         switch (info->type) {
 747         case IND_STATIC:
 748         case IND_OLDGEN:
 749         case IND_OLDGEN_PERM:
 750         case MUT_CONS:
 751             break;
 752         default:
 753             barf("checkMutOnceList: strange closure %p (%s)",
 754                  p, info_type((StgClosure *)p));
 755         }
 756     }
 757 }
 758
 759 /*
 760   Check the static objects list.
 761 */
 762 void
 763 checkStaticObjects ( StgClosure* static_objects )
 764 {
 765   StgClosure *p = static_objects;
 766   StgInfoTable *info;
 767
 768   while (p != END_OF_STATIC_LIST) {
 769     checkClosure(p);
 770     info = get_itbl(p);
 771     switch (info->type) {
 772     case IND_STATIC:
 773       {
 774         StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
 775
 776         ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
 777         ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
 778         p = IND_STATIC_LINK((StgClosure *)p);
 779         break;
 780       }
 781
 782     case THUNK_STATIC:
 783       p = THUNK_STATIC_LINK((StgClosure *)p);
 784       break;
 785
 786     case FUN_STATIC:
 787       p = FUN_STATIC_LINK((StgClosure *)p);
 788       break;
 789
 790     case CONSTR_STATIC:
 791       p = STATIC_LINK(info,(StgClosure *)p);
 792       break;
 793
 794     default:
 795       barf("checkStaticObjetcs: strange closure %p (%s)",
 796            p, info_type(p));
 797     }
 798   }
 799 }
 800
 801 /*
 802    Check the sanity of a blocking queue starting at bqe with closure being
 803    the closure holding the blocking queue.
 804    Note that in GUM we can have several different closure types in a
 805    blocking queue
 806 */
 807 #if defined(PAR)
 808 void
 809 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 810 {
 811   rtsBool end = rtsFalse;
 812   StgInfoTable *info = get_itbl(closure);
 813
 814   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
 815          || info->type == FETCH_ME_BQ || info->type == RBH);
 816
 817   do {
 818     switch (get_itbl(bqe)->type) {
 819     case BLOCKED_FETCH:
 820     case TSO:
 821       checkClosure((StgClosure *)bqe);
 822       bqe = bqe->link;
 823       end = (bqe==END_BQ_QUEUE);
 824       break;
 825
 826     case CONSTR:
 827       checkClosure((StgClosure *)bqe);
 828       end = rtsTrue;
 829       break;
 830
 831     default:
 832       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 833            get_itbl(bqe)->type, closure, info_type(closure));
 834     }
 835   } while (!end);
 836 }
 837 #elif defined(GRAN)
 838 void
 839 checkBQ (StgTSO *bqe, StgClosure *closure)
 840 {
 841   rtsBool end = rtsFalse;
 842   StgInfoTable *info = get_itbl(closure);
 843
 844   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 845
 846   do {
 847     switch (get_itbl(bqe)->type) {
 848     case BLOCKED_FETCH:
 849     case TSO:
 850       checkClosure((StgClosure *)bqe);
 851       bqe = bqe->link;
 852       end = (bqe==END_BQ_QUEUE);
 853       break;
 854
 855     default:
 856       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 857            get_itbl(bqe)->type, closure, info_type(closure));
 858     }
 859   } while (!end);
 860 }
 861 #else
 862 void
 863 checkBQ (StgTSO *bqe, StgClosure *closure)
 864 {
 865   rtsBool end = rtsFalse;
 866   StgInfoTable *info = get_itbl(closure);
 867
 868   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 869
 870   do {
 871     switch (get_itbl(bqe)->type) {
 872     case TSO:
 873       checkClosure((StgClosure *)bqe);
 874       bqe = bqe->link;
 875       end = (bqe==END_TSO_QUEUE);
 876       break;
 877
 878     default:
 879       barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
 880            get_itbl(bqe)->type, closure, info->type);
 881     }
 882   } while (!end);
 883 }
 884
 885 #endif
 886
 887
 888
 889 /*
 890   This routine checks the sanity of the LAGA and GALA tables. They are
 891   implemented as lists through one hash table, LAtoGALAtable, because entries
 892   in both tables have the same structure:
 893    - the LAGA table maps local addresses to global addresses; it starts
 894      with liveIndirections
 895    - the GALA table maps global addresses to local addresses; it starts
 896      with liveRemoteGAs
 897 */
 898
 899 #if defined(PAR)
 900 #include "Hash.h"
 901
 902 /* hidden in parallel/Global.c; only accessed for testing here */
 903 extern GALA *liveIndirections;
 904 extern GALA *liveRemoteGAs;
 905 extern HashTable *LAtoGALAtable;
 906
 907 void
 908 checkLAGAtable(rtsBool check_closures)
 909 {
 910   GALA *gala, *gala0;
 911   nat n=0, m=0; // debugging
 912
 913   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 914     n++;
 915     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 916     ASSERT(!gala->preferred || gala == gala0);
 917     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 918     ASSERT(gala->next!=gala); // detect direct loops
 919     if ( check_closures ) {
 920       checkClosure((StgClosure *)gala->la);
 921     }
 922   }
 923
 924   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 925     m++;
 926     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 927     ASSERT(!gala->preferred || gala == gala0);
 928     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 929     ASSERT(gala->next!=gala); // detect direct loops
 930     /*
 931     if ( check_closures ) {
 932       checkClosure((StgClosure *)gala->la);
 933     }
 934     */
 935   }
 936 }
 937 #endif
 938
 939 #endif /* DEBUG */