ghc/rts/Sanity.c

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