ghc/rts/Sanity.c

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