ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.30 2001/08/14 13:40:09 sewardj 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
  31 /* -----------------------------------------------------------------------------
  32    A valid pointer is either:
  33
  34      - a pointer to a static closure, or
  35      - a pointer into the heap, and
  36        - the block is not free
  37        - either: - the object is large, or
  38                  - it is not after the free pointer in the block
  39        - the contents of the pointer is not 0xaaaaaaaa
  40
  41    -------------------------------------------------------------------------- */
  42
  43 #define LOOKS_LIKE_PTR(r)                       \
  44   ({ bdescr *bd = Bdescr((P_)r);                \
  45      LOOKS_LIKE_STATIC_CLOSURE(r) ||            \
  46         (HEAP_ALLOCED(r)                        \
  47          && bd != (void *)-1                    \
  48          && ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa) \
  49         );                                      \
  50    })
  51
  52 // NOT always true, but can be useful for spotting bugs: (generally
  53 // true after GC, but not for things just allocated using allocate(),
  54 // for example):
  55 //          (bd->flags & BF_LARGE || bd->free > (P_)r)
  56
  57 /* -----------------------------------------------------------------------------
  58    Forward decls.
  59    -------------------------------------------------------------------------- */
  60
  61 static StgOffset checkStackClosure   ( StgClosure* c );
  62 static StgOffset checkStackObject    ( StgPtr sp );
  63 static StgOffset checkSmallBitmap    ( StgPtr payload, StgWord bitmap );
  64 static StgOffset checkLargeBitmap    ( StgPtr payload, StgLargeBitmap* );
  65 static void      checkClosureShallow ( StgClosure* p );
  66
  67 /* -----------------------------------------------------------------------------
  68    Check stack sanity
  69    -------------------------------------------------------------------------- */
  70
  71 static StgOffset
  72 checkSmallBitmap( StgPtr payload, StgWord bitmap )
  73 {
  74     StgOffset i;
  75
  76     i = 0;
  77     for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  78         if ((bitmap & 1) == 0) {
  79             checkClosure((StgClosure *)payload[i]);
  80         }
  81     }
  82     return i;
  83 }
  84
  85 static StgOffset
  86 checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap )
  87 {
  88     StgWord bmp;
  89     StgOffset i;
  90
  91     i = 0;
  92     for (bmp=0; bmp<large_bitmap->size; bmp++) {
  93         StgWord bitmap = large_bitmap->bitmap[bmp];
  94         for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  95             if ((bitmap & 1) == 0) {
  96                 checkClosure((StgClosure *)payload[i]);
  97             }
  98         }
  99     }
 100     return i;
 101 }
 102
 103 static StgOffset
 104 checkStackClosure( StgClosure* c )
 105 {
 106     const StgInfoTable* info = get_itbl(c);
 107
 108     /* All activation records have 'bitmap' style layout info. */
 109     switch (info->type) {
 110     case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
 111         {
 112             StgRetDyn* r = (StgRetDyn *)c;
 113             return sizeofW(StgRetDyn) +
 114                    checkSmallBitmap(r->payload,r->liveness);
 115         }
 116     case RET_BCO: /* small bitmap (<= 32 entries) */
 117     case RET_SMALL:
 118     case RET_VEC_SMALL:
 119             return 1 + checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap);
 120
 121     case UPDATE_FRAME:
 122       ASSERT(LOOKS_LIKE_PTR(((StgUpdateFrame*)c)->updatee));
 123     case CATCH_FRAME:
 124     case SEQ_FRAME:
 125       /* check that the link field points to another stack frame */
 126       ASSERT(get_itbl(((StgFrame*)c)->link)->type == UPDATE_FRAME ||
 127              get_itbl(((StgFrame*)c)->link)->type == CATCH_FRAME ||
 128              get_itbl(((StgFrame*)c)->link)->type == STOP_FRAME ||
 129              get_itbl(((StgFrame*)c)->link)->type == SEQ_FRAME);
 130       /* fall through */
 131     case STOP_FRAME:
 132 #if defined(GRAN)
 133             return 2 +
 134 #else
 135             return 1 +
 136 #endif
 137                        checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap);
 138     case RET_BIG: /* large bitmap (> 32 entries) */
 139     case RET_VEC_BIG:
 140             return 1 + checkLargeBitmap((StgPtr)c + 1,info->layout.large_bitmap);
 141     case FUN:
 142     case FUN_STATIC: /* probably a slow-entry point return address: */
 143 #if 0 && defined(GRAN)
 144             return 2;
 145 #else
 146             return 1;
 147 #endif
 148     default:
 149             /* if none of the above, maybe it's a closure which looks a
 150              * little like an infotable
 151              */
 152             checkClosureShallow(*(StgClosure **)c);
 153             return 1;
 154             /* barf("checkStackClosure: weird activation record found on stack (%p).",c); */
 155     }
 156 }
 157
 158 /*
 159  * check that it looks like a valid closure - without checking its payload
 160  * used to avoid recursion between checking PAPs and checking stack
 161  * chunks.
 162  */
 163
 164 void
 165 checkClosureShallow( StgClosure* p )
 166 {
 167     ASSERT(p);
 168     ASSERT(LOOKS_LIKE_GHC_INFO(GET_INFO(p))
 169            || IS_HUGS_CONSTR_INFO(GET_INFO(p)));
 170
 171     /* Is it a static closure (i.e. in the data segment)? */
 172     if (LOOKS_LIKE_STATIC(p)) {
 173         ASSERT(closure_STATIC(p));
 174     } else {
 175         ASSERT(!closure_STATIC(p));
 176         ASSERT(LOOKS_LIKE_PTR(p));
 177     }
 178 }
 179
 180 // check an individual stack object
 181 StgOffset
 182 checkStackObject( StgPtr sp )
 183 {
 184     if (IS_ARG_TAG(*sp)) {
 185         // Tagged words might be "stubbed" pointers, so there's no
 186         // point checking to see whether they look like pointers or
 187         // not (some of them will).
 188         return ARG_SIZE(*sp) + 1;
 189     } else if (LOOKS_LIKE_GHC_INFO(*(StgPtr *)sp)) {
 190         return checkStackClosure((StgClosure *)sp);
 191     } else { // must be an untagged closure pointer in the stack
 192         checkClosureShallow(*(StgClosure **)sp);
 193         return 1;
 194     }
 195 }
 196
 197 // check sections of stack between update frames
 198 void
 199 checkStackChunk( StgPtr sp, StgPtr stack_end )
 200 {
 201     StgPtr p;
 202
 203     p = sp;
 204     while (p < stack_end) {
 205         p += checkStackObject( p );
 206     }
 207     // ASSERT( p == stack_end ); -- HWL
 208 }
 209
 210 StgOffset
 211 checkClosure( StgClosure* p )
 212 {
 213     const StgInfoTable *info;
 214
 215     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
 216
 217     /* Is it a static closure (i.e. in the data segment)? */
 218     if (LOOKS_LIKE_STATIC(p)) {
 219         ASSERT(closure_STATIC(p));
 220     } else {
 221         ASSERT(!closure_STATIC(p));
 222         ASSERT(LOOKS_LIKE_PTR(p));
 223     }
 224
 225     info = get_itbl(p);
 226     switch (info->type) {
 227
 228     case MVAR:
 229       {
 230         StgMVar *mvar = (StgMVar *)p;
 231         ASSERT(LOOKS_LIKE_PTR(mvar->head));
 232         ASSERT(LOOKS_LIKE_PTR(mvar->tail));
 233         ASSERT(LOOKS_LIKE_PTR(mvar->value));
 234 #if 0
 235 #if defined(PAR)
 236         checkBQ((StgBlockingQueueElement *)mvar->head, p);
 237 #else
 238         checkBQ(mvar->head, p);
 239 #endif
 240 #endif
 241         return sizeofW(StgMVar);
 242       }
 243
 244     case THUNK:
 245     case THUNK_1_0:
 246     case THUNK_0_1:
 247     case THUNK_1_1:
 248     case THUNK_0_2:
 249     case THUNK_2_0:
 250       {
 251         nat i;
 252         for (i = 0; i < info->layout.payload.ptrs; i++) {
 253           ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 254         }
 255         return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
 256       }
 257
 258     case BLACKHOLE_BQ:
 259       checkBQ(((StgBlockingQueue *)p)->blocking_queue, p);
 260       /* fall through to basic ptr check */
 261     case FUN:
 262     case FUN_1_0:
 263     case FUN_0_1:
 264     case FUN_1_1:
 265     case FUN_0_2:
 266     case FUN_2_0:
 267     case CONSTR:
 268     case CONSTR_1_0:
 269     case CONSTR_0_1:
 270     case CONSTR_1_1:
 271     case CONSTR_0_2:
 272     case CONSTR_2_0:
 273     case IND_PERM:
 274     case IND_OLDGEN:
 275     case IND_OLDGEN_PERM:
 276 #ifdef TICKY_TICKY
 277     case SE_BLACKHOLE:
 278     case SE_CAF_BLACKHOLE:
 279 #endif
 280     case BLACKHOLE:
 281     case CAF_BLACKHOLE:
 282     case FOREIGN:
 283     case BCO:
 284     case STABLE_NAME:
 285     case MUT_VAR:
 286     case MUT_CONS:
 287     case CONSTR_INTLIKE:
 288     case CONSTR_CHARLIKE:
 289     case CONSTR_STATIC:
 290     case CONSTR_NOCAF_STATIC:
 291     case THUNK_STATIC:
 292     case FUN_STATIC:
 293         {
 294             nat i;
 295             for (i = 0; i < info->layout.payload.ptrs; i++) {
 296                 ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 297             }
 298             return sizeW_fromITBL(info);
 299         }
 300
 301     case IND_STATIC: /* (1, 0) closure */
 302       ASSERT(LOOKS_LIKE_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_PTR(w->key));
 311         ASSERT(LOOKS_LIKE_PTR(w->value));
 312         ASSERT(LOOKS_LIKE_PTR(w->finalizer));
 313         if (w->link) {
 314           ASSERT(LOOKS_LIKE_PTR(w->link));
 315         }
 316         return sizeW_fromITBL(info);
 317       }
 318
 319     case THUNK_SELECTOR:
 320             ASSERT(LOOKS_LIKE_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_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     case SEQ_FRAME:
 346             barf("checkClosure: stack frame");
 347
 348     case AP_UPD: /* we can treat this as being the same as a PAP */
 349     case PAP:
 350         {
 351             StgPAP *pap = (StgPAP *)p;
 352             ASSERT(LOOKS_LIKE_PTR(pap->fun));
 353             checkStackChunk((StgPtr)pap->payload,
 354                             (StgPtr)pap->payload + pap->n_args
 355                             );
 356             return pap_sizeW(pap);
 357         }
 358
 359     case ARR_WORDS:
 360             return arr_words_sizeW((StgArrWords *)p);
 361
 362     case MUT_ARR_PTRS:
 363     case MUT_ARR_PTRS_FROZEN:
 364         {
 365             StgMutArrPtrs* a = (StgMutArrPtrs *)p;
 366             nat i;
 367             for (i = 0; i < a->ptrs; i++) {
 368                 ASSERT(LOOKS_LIKE_PTR(a->payload[i]));
 369             }
 370             return mut_arr_ptrs_sizeW(a);
 371         }
 372
 373     case TSO:
 374         checkTSO((StgTSO *)p);
 375         return tso_sizeW((StgTSO *)p);
 376
 377 #if defined(PAR)
 378
 379     case BLOCKED_FETCH:
 380       ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
 381       ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
 382       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 383
 384 #ifdef DIST
 385     case REMOTE_REF:
 386       return sizeofW(StgFetchMe);
 387 #endif //DIST
 388
 389     case FETCH_ME:
 390       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 391       return sizeofW(StgFetchMe);  // see size used in evacuate()
 392
 393     case FETCH_ME_BQ:
 394       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 395       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 396
 397     case RBH:
 398       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 399       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 400       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 401         checkBQ(((StgRBH *)p)->blocking_queue, p);
 402       ASSERT(LOOKS_LIKE_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 403       return BLACKHOLE_sizeW();   // see size used in evacuate()
 404       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 405
 406 #endif
 407
 408     case EVACUATED:
 409             barf("checkClosure: found EVACUATED closure %d",
 410                  info->type);
 411     default:
 412             barf("checkClosure (closure type %d)", info->type);
 413     }
 414 }
 415
 416 #if defined(PAR)
 417
 418 #define PVM_PE_MASK    0xfffc0000
 419 #define MAX_PVM_PES    MAX_PES
 420 #define MAX_PVM_TIDS   MAX_PES
 421 #define MAX_SLOTS      100000
 422
 423 rtsBool
 424 looks_like_tid(StgInt tid)
 425 {
 426   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 427   StgInt lo = (tid & ~PVM_PE_MASK);
 428   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 429   return ok;
 430 }
 431
 432 rtsBool
 433 looks_like_slot(StgInt slot)
 434 {
 435   /* if tid is known better use looks_like_ga!! */
 436   rtsBool ok = slot<MAX_SLOTS;
 437   // This refers only to the no. of slots on the current PE
 438   // rtsBool ok = slot<=highest_slot();
 439   return ok;
 440 }
 441
 442 rtsBool
 443 looks_like_ga(globalAddr *ga)
 444 {
 445   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 446   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 447                      (ga)->payload.gc.slot<=highest_slot() :
 448                      (ga)->payload.gc.slot<MAX_SLOTS;
 449   rtsBool ok = is_tid && is_slot;
 450   return ok;
 451 }
 452
 453 #endif
 454
 455
 456 /* -----------------------------------------------------------------------------
 457    Check Heap Sanity
 458
 459    After garbage collection, the live heap is in a state where we can
 460    run through and check that all the pointers point to the right
 461    place.  This function starts at a given position and sanity-checks
 462    all the objects in the remainder of the chain.
 463    -------------------------------------------------------------------------- */
 464
 465 void
 466 checkHeap(bdescr *bd)
 467 {
 468     StgPtr p;
 469
 470     for (; bd != NULL; bd = bd->link) {
 471         p = bd->start;
 472         while (p < bd->free) {
 473             nat size = checkClosure((StgClosure *)p);
 474             /* This is the smallest size of closure that can live in the heap */
 475             ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 476             p += size;
 477
 478             /* skip over slop */
 479             while (p < bd->free &&
 480                    (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
 481         }
 482     }
 483 }
 484
 485 #if defined(PAR)
 486 /*
 487    Check heap between start and end. Used after unpacking graphs.
 488 */
 489 void
 490 checkHeapChunk(StgPtr start, StgPtr end)
 491 {
 492   extern globalAddr *LAGAlookup(StgClosure *addr);
 493   StgPtr p;
 494   nat size;
 495
 496   for (p=start; p<end; p+=size) {
 497     ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
 498     if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
 499         *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
 500       /* if it's a FM created during unpack and commoned up, it's not global */
 501       ASSERT(LAGAlookup((StgClosure*)p)==NULL);
 502       size = sizeofW(StgFetchMe);
 503     } else if (get_itbl((StgClosure*)p)->type == IND) {
 504       *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
 505       size = MIN_UPD_SIZE;
 506     } else {
 507       size = checkClosure((StgClosure *)p);
 508       /* This is the smallest size of closure that can live in the heap. */
 509       ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 510     }
 511   }
 512 }
 513 #else /* !PAR */
 514 void
 515 checkHeapChunk(StgPtr start, StgPtr end)
 516 {
 517   StgPtr p;
 518   nat size;
 519
 520   for (p=start; p<end; p+=size) {
 521     ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
 522     size = checkClosure((StgClosure *)p);
 523     /* This is the smallest size of closure that can live in the heap. */
 524     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 525   }
 526 }
 527 #endif
 528
 529 void
 530 checkChain(bdescr *bd)
 531 {
 532   while (bd != NULL) {
 533     checkClosure((StgClosure *)bd->start);
 534     bd = bd->link;
 535   }
 536 }
 537
 538 /* check stack - making sure that update frames are linked correctly */
 539 void
 540 checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
 541 {
 542     /* check everything down to the first update frame */
 543     checkStackChunk( sp, (StgPtr)su );
 544     while ( (StgPtr)su < stack_end) {
 545         sp = (StgPtr)su;
 546         switch (get_itbl(su)->type) {
 547         case UPDATE_FRAME:
 548                 su = su->link;
 549                 break;
 550         case SEQ_FRAME:
 551                 su = ((StgSeqFrame *)su)->link;
 552                 break;
 553         case CATCH_FRAME:
 554                 su = ((StgCatchFrame *)su)->link;
 555                 break;
 556         case STOP_FRAME:
 557                 /* not quite: ASSERT((StgPtr)su == stack_end); */
 558                 return;
 559         default:
 560                 barf("checkStack: weird record found on update frame list.");
 561         }
 562         checkStackChunk( sp, (StgPtr)su );
 563     }
 564     ASSERT((StgPtr)su == stack_end);
 565 }
 566
 567
 568 void
 569 checkTSO(StgTSO *tso)
 570 {
 571     StgPtr sp = tso->sp;
 572     StgPtr stack = tso->stack;
 573     StgUpdateFrame* su = tso->su;
 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 == ThreadComplete || 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     ASSERT(sp <= (StgPtr)su);
 591
 592 #if defined(PAR)
 593     ASSERT(tso->par.magic==TSO_MAGIC);
 594
 595     switch (tso->why_blocked) {
 596     case BlockedOnGA:
 597       checkClosureShallow(tso->block_info.closure);
 598       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 599              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 600       break;
 601     case BlockedOnGA_NoSend:
 602       checkClosureShallow(tso->block_info.closure);
 603       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 604       break;
 605     case BlockedOnBlackHole:
 606       checkClosureShallow(tso->block_info.closure);
 607       ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
 608              get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
 609              get_itbl(tso->block_info.closure)->type==RBH);
 610       break;
 611     case BlockedOnRead:
 612     case BlockedOnWrite:
 613     case BlockedOnDelay:
 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     checkStack(sp, stack_end, su);
 639 }
 640
 641 #if defined(GRAN)
 642 void
 643 checkTSOsSanity(void) {
 644   nat i, tsos;
 645   StgTSO *tso;
 646
 647   belch("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       fprintf(stderr, "TSO %p on PE %d ...", tso, i);
 652       checkTSO(tso);
 653       fprintf(stderr, "OK, ");
 654       tsos++;
 655     }
 656   }
 657
 658   belch(" 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_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_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_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 Blackhole Sanity
 759
 760    Test whether an object is already on the update list.
 761    It isn't necessarily an rts error if it is - it might be a programming
 762    error.
 763
 764    Future versions might be able to test for a blackhole without traversing
 765    the update frame list.
 766
 767    -------------------------------------------------------------------------- */
 768 rtsBool
 769 isBlackhole( StgTSO* tso, StgClosure* p )
 770 {
 771   StgUpdateFrame* su = tso->su;
 772   do {
 773     switch (get_itbl(su)->type) {
 774     case UPDATE_FRAME:
 775       if (su->updatee == p) {
 776         return rtsTrue;
 777       } else {
 778         su = su->link;
 779       }
 780       break;
 781     case SEQ_FRAME:
 782       su = ((StgSeqFrame *)su)->link;
 783       break;
 784     case CATCH_FRAME:
 785       su = ((StgCatchFrame *)su)->link;
 786       break;
 787     case STOP_FRAME:
 788       return rtsFalse;
 789     default:
 790       barf("isBlackhole: weird record found on update frame list.");
 791     }
 792   } while (1);
 793 }
 794
 795 /*
 796   Check the static objects list.
 797 */
 798 void
 799 checkStaticObjects ( StgClosure* static_objects )
 800 {
 801   StgClosure *p = static_objects;
 802   StgInfoTable *info;
 803
 804   while (p != END_OF_STATIC_LIST) {
 805     checkClosure(p);
 806     info = get_itbl(p);
 807     switch (info->type) {
 808     case IND_STATIC:
 809       {
 810         StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
 811
 812         ASSERT(LOOKS_LIKE_PTR(indirectee));
 813         ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info));
 814         p = IND_STATIC_LINK((StgClosure *)p);
 815         break;
 816       }
 817
 818     case THUNK_STATIC:
 819       p = THUNK_STATIC_LINK((StgClosure *)p);
 820       break;
 821
 822     case FUN_STATIC:
 823       p = FUN_STATIC_LINK((StgClosure *)p);
 824       break;
 825
 826     case CONSTR_STATIC:
 827       p = STATIC_LINK(info,(StgClosure *)p);
 828       break;
 829
 830     default:
 831       barf("checkStaticObjetcs: strange closure %p (%s)",
 832            p, info_type(p));
 833     }
 834   }
 835 }
 836
 837 /*
 838    Check the sanity of a blocking queue starting at bqe with closure being
 839    the closure holding the blocking queue.
 840    Note that in GUM we can have several different closure types in a
 841    blocking queue
 842 */
 843 #if defined(PAR)
 844 void
 845 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 846 {
 847   rtsBool end = rtsFalse;
 848   StgInfoTable *info = get_itbl(closure);
 849
 850   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
 851          || info->type == FETCH_ME_BQ || info->type == RBH);
 852
 853   do {
 854     switch (get_itbl(bqe)->type) {
 855     case BLOCKED_FETCH:
 856     case TSO:
 857       checkClosure((StgClosure *)bqe);
 858       bqe = bqe->link;
 859       end = (bqe==END_BQ_QUEUE);
 860       break;
 861
 862     case CONSTR:
 863       checkClosure((StgClosure *)bqe);
 864       end = rtsTrue;
 865       break;
 866
 867     default:
 868       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 869            get_itbl(bqe)->type, closure, info_type(closure));
 870     }
 871   } while (!end);
 872 }
 873 #elif defined(GRAN)
 874 void
 875 checkBQ (StgTSO *bqe, StgClosure *closure)
 876 {
 877   rtsBool end = rtsFalse;
 878   StgInfoTable *info = get_itbl(closure);
 879
 880   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 881
 882   do {
 883     switch (get_itbl(bqe)->type) {
 884     case BLOCKED_FETCH:
 885     case TSO:
 886       checkClosure((StgClosure *)bqe);
 887       bqe = bqe->link;
 888       end = (bqe==END_BQ_QUEUE);
 889       break;
 890
 891     default:
 892       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 893            get_itbl(bqe)->type, closure, info_type(closure));
 894     }
 895   } while (!end);
 896 }
 897 #else
 898 void
 899 checkBQ (StgTSO *bqe, StgClosure *closure)
 900 {
 901   rtsBool end = rtsFalse;
 902   StgInfoTable *info = get_itbl(closure);
 903
 904   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 905
 906   do {
 907     switch (get_itbl(bqe)->type) {
 908     case TSO:
 909       checkClosure((StgClosure *)bqe);
 910       bqe = bqe->link;
 911       end = (bqe==END_TSO_QUEUE);
 912       break;
 913
 914     default:
 915       barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
 916            get_itbl(bqe)->type, closure, info->type);
 917     }
 918   } while (!end);
 919 }
 920
 921 #endif
 922
 923
 924
 925 /*
 926   This routine checks the sanity of the LAGA and GALA tables. They are
 927   implemented as lists through one hash table, LAtoGALAtable, because entries
 928   in both tables have the same structure:
 929    - the LAGA table maps local addresses to global addresses; it starts
 930      with liveIndirections
 931    - the GALA table maps global addresses to local addresses; it starts
 932      with liveRemoteGAs
 933 */
 934
 935 #if defined(PAR)
 936 #include "Hash.h"
 937
 938 /* hidden in parallel/Global.c; only accessed for testing here */
 939 extern GALA *liveIndirections;
 940 extern GALA *liveRemoteGAs;
 941 extern HashTable *LAtoGALAtable;
 942
 943 void
 944 checkLAGAtable(rtsBool check_closures)
 945 {
 946   GALA *gala, *gala0;
 947   nat n=0, m=0; // debugging
 948
 949   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 950     n++;
 951     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 952     ASSERT(!gala->preferred || gala == gala0);
 953     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 954     ASSERT(gala->next!=gala); // detect direct loops
 955     if ( check_closures ) {
 956       checkClosure((StgClosure *)gala->la);
 957     }
 958   }
 959
 960   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 961     m++;
 962     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 963     ASSERT(!gala->preferred || gala == gala0);
 964     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 965     ASSERT(gala->next!=gala); // detect direct loops
 966     /*
 967     if ( check_closures ) {
 968       checkClosure((StgClosure *)gala->la);
 969     }
 970     */
 971   }
 972 }
 973 #endif
 974
 975 #endif /* DEBUG */