ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.33 2003/04/22 16:25:12 simonmar 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       /* isOnBQ(blocked_queue) */
 614       break;
 615     case BlockedOnException:
 616       /* isOnSomeBQ(tso) */
 617       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 618       break;
 619     case BlockedOnMVar:
 620       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 621       break;
 622     default:
 623       /*
 624          Could check other values of why_blocked but I am more
 625          lazy than paranoid (bad combination) -- HWL
 626       */
 627     }
 628
 629     /* if the link field is non-nil it most point to one of these
 630        three closure types */
 631     ASSERT(tso->link == END_TSO_QUEUE ||
 632            get_itbl(tso->link)->type == TSO ||
 633            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 634            get_itbl(tso->link)->type == CONSTR);
 635 #endif
 636
 637     checkStackChunk(sp, stack_end);
 638 }
 639
 640 #if defined(GRAN)
 641 void
 642 checkTSOsSanity(void) {
 643   nat i, tsos;
 644   StgTSO *tso;
 645
 646   belch("Checking sanity of all runnable TSOs:");
 647
 648   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 649     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 650       fprintf(stderr, "TSO %p on PE %d ...", tso, i);
 651       checkTSO(tso);
 652       fprintf(stderr, "OK, ");
 653       tsos++;
 654     }
 655   }
 656
 657   belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 658 }
 659
 660
 661 // still GRAN only
 662
 663 rtsBool
 664 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 665 {
 666   StgTSO *tso, *prev;
 667
 668   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 669   ASSERT(run_queue_hds[proc]!=NULL);
 670   ASSERT(run_queue_tls[proc]!=NULL);
 671   /* if either head or tail is NIL then the other one must be NIL, too */
 672   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 673   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 674   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 675        tso!=END_TSO_QUEUE;
 676        prev=tso, tso=tso->link) {
 677     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 678            (prev==END_TSO_QUEUE || prev->link==tso));
 679     if (check_TSO_too)
 680       checkTSO(tso);
 681   }
 682   ASSERT(prev==run_queue_tls[proc]);
 683 }
 684
 685 rtsBool
 686 checkThreadQsSanity (rtsBool check_TSO_too)
 687 {
 688   PEs p;
 689
 690   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 691     checkThreadQSanity(p, check_TSO_too);
 692 }
 693 #endif /* GRAN */
 694
 695 /*
 696    Check that all TSOs have been evacuated.
 697    Optionally also check the sanity of the TSOs.
 698 */
 699 void
 700 checkGlobalTSOList (rtsBool checkTSOs)
 701 {
 702   extern  StgTSO *all_threads;
 703   StgTSO *tso;
 704   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 705       ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
 706       ASSERT(get_itbl(tso)->type == TSO);
 707       if (checkTSOs)
 708           checkTSO(tso);
 709   }
 710 }
 711
 712 /* -----------------------------------------------------------------------------
 713    Check mutable list sanity.
 714    -------------------------------------------------------------------------- */
 715
 716 void
 717 checkMutableList( StgMutClosure *p, nat gen )
 718 {
 719     bdescr *bd;
 720
 721     for (; p != END_MUT_LIST; p = p->mut_link) {
 722         bd = Bdescr((P_)p);
 723         ASSERT(closure_MUTABLE(p));
 724         ASSERT(bd->gen_no == gen);
 725         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
 726     }
 727 }
 728
 729 void
 730 checkMutOnceList( StgMutClosure *p, nat gen )
 731 {
 732     bdescr *bd;
 733     StgInfoTable *info;
 734
 735     for (; p != END_MUT_LIST; p = p->mut_link) {
 736         bd = Bdescr((P_)p);
 737         info = get_itbl(p);
 738
 739         ASSERT(!closure_MUTABLE(p));
 740         ASSERT(ip_STATIC(info) || bd->gen_no == gen);
 741         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
 742
 743         switch (info->type) {
 744         case IND_STATIC:
 745         case IND_OLDGEN:
 746         case IND_OLDGEN_PERM:
 747         case MUT_CONS:
 748             break;
 749         default:
 750             barf("checkMutOnceList: strange closure %p (%s)",
 751                  p, info_type((StgClosure *)p));
 752         }
 753     }
 754 }
 755
 756 /*
 757   Check the static objects list.
 758 */
 759 void
 760 checkStaticObjects ( StgClosure* static_objects )
 761 {
 762   StgClosure *p = static_objects;
 763   StgInfoTable *info;
 764
 765   while (p != END_OF_STATIC_LIST) {
 766     checkClosure(p);
 767     info = get_itbl(p);
 768     switch (info->type) {
 769     case IND_STATIC:
 770       {
 771         StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
 772
 773         ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
 774         ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
 775         p = IND_STATIC_LINK((StgClosure *)p);
 776         break;
 777       }
 778
 779     case THUNK_STATIC:
 780       p = THUNK_STATIC_LINK((StgClosure *)p);
 781       break;
 782
 783     case FUN_STATIC:
 784       p = FUN_STATIC_LINK((StgClosure *)p);
 785       break;
 786
 787     case CONSTR_STATIC:
 788       p = STATIC_LINK(info,(StgClosure *)p);
 789       break;
 790
 791     default:
 792       barf("checkStaticObjetcs: strange closure %p (%s)",
 793            p, info_type(p));
 794     }
 795   }
 796 }
 797
 798 /*
 799    Check the sanity of a blocking queue starting at bqe with closure being
 800    the closure holding the blocking queue.
 801    Note that in GUM we can have several different closure types in a
 802    blocking queue
 803 */
 804 #if defined(PAR)
 805 void
 806 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 807 {
 808   rtsBool end = rtsFalse;
 809   StgInfoTable *info = get_itbl(closure);
 810
 811   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
 812          || info->type == FETCH_ME_BQ || info->type == RBH);
 813
 814   do {
 815     switch (get_itbl(bqe)->type) {
 816     case BLOCKED_FETCH:
 817     case TSO:
 818       checkClosure((StgClosure *)bqe);
 819       bqe = bqe->link;
 820       end = (bqe==END_BQ_QUEUE);
 821       break;
 822
 823     case CONSTR:
 824       checkClosure((StgClosure *)bqe);
 825       end = rtsTrue;
 826       break;
 827
 828     default:
 829       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 830            get_itbl(bqe)->type, closure, info_type(closure));
 831     }
 832   } while (!end);
 833 }
 834 #elif defined(GRAN)
 835 void
 836 checkBQ (StgTSO *bqe, StgClosure *closure)
 837 {
 838   rtsBool end = rtsFalse;
 839   StgInfoTable *info = get_itbl(closure);
 840
 841   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 842
 843   do {
 844     switch (get_itbl(bqe)->type) {
 845     case BLOCKED_FETCH:
 846     case TSO:
 847       checkClosure((StgClosure *)bqe);
 848       bqe = bqe->link;
 849       end = (bqe==END_BQ_QUEUE);
 850       break;
 851
 852     default:
 853       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 854            get_itbl(bqe)->type, closure, info_type(closure));
 855     }
 856   } while (!end);
 857 }
 858 #else
 859 void
 860 checkBQ (StgTSO *bqe, StgClosure *closure)
 861 {
 862   rtsBool end = rtsFalse;
 863   StgInfoTable *info = get_itbl(closure);
 864
 865   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 866
 867   do {
 868     switch (get_itbl(bqe)->type) {
 869     case TSO:
 870       checkClosure((StgClosure *)bqe);
 871       bqe = bqe->link;
 872       end = (bqe==END_TSO_QUEUE);
 873       break;
 874
 875     default:
 876       barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
 877            get_itbl(bqe)->type, closure, info->type);
 878     }
 879   } while (!end);
 880 }
 881
 882 #endif
 883
 884
 885
 886 /*
 887   This routine checks the sanity of the LAGA and GALA tables. They are
 888   implemented as lists through one hash table, LAtoGALAtable, because entries
 889   in both tables have the same structure:
 890    - the LAGA table maps local addresses to global addresses; it starts
 891      with liveIndirections
 892    - the GALA table maps global addresses to local addresses; it starts
 893      with liveRemoteGAs
 894 */
 895
 896 #if defined(PAR)
 897 #include "Hash.h"
 898
 899 /* hidden in parallel/Global.c; only accessed for testing here */
 900 extern GALA *liveIndirections;
 901 extern GALA *liveRemoteGAs;
 902 extern HashTable *LAtoGALAtable;
 903
 904 void
 905 checkLAGAtable(rtsBool check_closures)
 906 {
 907   GALA *gala, *gala0;
 908   nat n=0, m=0; // debugging
 909
 910   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 911     n++;
 912     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 913     ASSERT(!gala->preferred || gala == gala0);
 914     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 915     ASSERT(gala->next!=gala); // detect direct loops
 916     if ( check_closures ) {
 917       checkClosure((StgClosure *)gala->la);
 918     }
 919   }
 920
 921   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 922     m++;
 923     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 924     ASSERT(!gala->preferred || gala == gala0);
 925     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 926     ASSERT(gala->next!=gala); // detect direct loops
 927     /*
 928     if ( check_closures ) {
 929       checkClosure((StgClosure *)gala->la);
 930     }
 931     */
 932   }
 933 }
 934 #endif
 935
 936 #endif /* DEBUG */