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