ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.22 2000/11/13 14:40:37 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Sanity checking code for the heap and stack.
   7  *
   8  * Used when debugging: check that the stack looks 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 //@menu
  18 //* Includes::
  19 //* Macros::
  20 //* Stack sanity::
  21 //* Heap Sanity::
  22 //* TSO Sanity::
  23 //* Thread Queue Sanity::
  24 //* Blackhole Sanity::
  25 //@end menu
  26
  27 //@node Includes, Macros
  28 //@subsection Includes
  29
  30 #include "Rts.h"
  31
  32 #ifdef DEBUG                                                   /* whole file */
  33
  34 #include "RtsFlags.h"
  35 #include "RtsUtils.h"
  36 #include "BlockAlloc.h"
  37 #include "Sanity.h"
  38 #include "Schedule.h"
  39 #include "StoragePriv.h"   // for END_OF_STATIC_LIST
  40
  41 //@node Macros, Stack sanity, Includes
  42 //@subsection Macros
  43
  44 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
  45                             ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
  46                              ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
  47
  48 //@node Stack sanity, Heap Sanity, Macros
  49 //@subsection Stack sanity
  50
  51 /* -----------------------------------------------------------------------------
  52    Check stack sanity
  53    -------------------------------------------------------------------------- */
  54
  55 StgOffset checkStackClosure( StgClosure* c );
  56
  57 StgOffset checkStackObject( StgPtr sp );
  58
  59 void      checkStackChunk( StgPtr sp, StgPtr stack_end );
  60
  61 static StgOffset checkSmallBitmap(  StgPtr payload, StgWord32 bitmap );
  62
  63 static StgOffset checkLargeBitmap( StgPtr payload,
  64                                    StgLargeBitmap* large_bitmap );
  65
  66 void checkClosureShallow( StgClosure* p );
  67
  68 //@cindex checkSmallBitmap
  69 static StgOffset
  70 checkSmallBitmap( StgPtr payload, StgWord32 bitmap )
  71 {
  72     StgOffset i;
  73
  74     i = 0;
  75     for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  76         if ((bitmap & 1) == 0) {
  77             checkClosure(stgCast(StgClosure*,payload[i]));
  78         }
  79     }
  80     return i;
  81 }
  82
  83 //@cindex checkLargeBitmap
  84 static StgOffset
  85 checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap )
  86 {
  87     StgWord32 bmp;
  88     StgOffset i;
  89
  90     i = 0;
  91     for (bmp=0; bmp<large_bitmap->size; bmp++) {
  92         StgWord32 bitmap = large_bitmap->bitmap[bmp];
  93         for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  94             if ((bitmap & 1) == 0) {
  95                 checkClosure(stgCast(StgClosure*,payload[i]));
  96             }
  97         }
  98     }
  99     return i;
 100 }
 101
 102 //@cindex checkStackClosure
 103 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 //@cindex checkClosureShallow
 165 void
 166 checkClosureShallow( StgClosure* p )
 167 {
 168     ASSERT(p);
 169     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info)
 170            || IS_HUGS_CONSTR_INFO(GET_INFO(p)));
 171
 172     /* Is it a static closure (i.e. in the data segment)? */
 173     if (LOOKS_LIKE_STATIC(p)) {
 174         ASSERT(closure_STATIC(p));
 175     } else {
 176         ASSERT(!closure_STATIC(p));
 177         ASSERT(LOOKS_LIKE_PTR(p));
 178     }
 179 }
 180
 181 /* check an individual stack object */
 182 //@cindex checkStackObject
 183 StgOffset
 184 checkStackObject( StgPtr sp )
 185 {
 186     if (IS_ARG_TAG(*sp)) {
 187         /* Tagged words might be "stubbed" pointers, so there's no
 188          * point checking to see whether they look like pointers or
 189          * not (some of them will).
 190          */
 191         return ARG_SIZE(*sp) + 1;
 192     } else if (LOOKS_LIKE_GHC_INFO(*stgCast(StgPtr*,sp))) {
 193         return checkStackClosure(stgCast(StgClosure*,sp));
 194     } else { /* must be an untagged closure pointer in the stack */
 195         checkClosureShallow(*stgCast(StgClosure**,sp));
 196         return 1;
 197     }
 198 }
 199
 200 /* check sections of stack between update frames */
 201 //@cindex checkStackChunk
 202 void
 203 checkStackChunk( StgPtr sp, StgPtr stack_end )
 204 {
 205     StgPtr p;
 206
 207     p = sp;
 208     while (p < stack_end) {
 209         p += checkStackObject( p );
 210     }
 211     // ASSERT( p == stack_end ); -- HWL
 212 }
 213
 214 //@cindex checkStackChunk
 215 StgOffset
 216 checkClosure( StgClosure* p )
 217 {
 218     const StgInfoTable *info;
 219
 220 #ifndef INTERPRETER
 221     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
 222 #endif
 223
 224     /* Is it a static closure (i.e. in the data segment)? */
 225     if (LOOKS_LIKE_STATIC(p)) {
 226         ASSERT(closure_STATIC(p));
 227     } else {
 228         ASSERT(!closure_STATIC(p));
 229         ASSERT(LOOKS_LIKE_PTR(p));
 230     }
 231
 232     info = get_itbl(p);
 233     switch (info->type) {
 234     case BCO:
 235         {
 236             StgBCO* bco = stgCast(StgBCO*,p);
 237             nat i;
 238             for(i=0; i < bco->n_ptrs; ++i) {
 239                 ASSERT(LOOKS_LIKE_PTR(bcoConstPtr(bco,i)));
 240             }
 241             return bco_sizeW(bco);
 242         }
 243
 244     case MVAR:
 245       {
 246         StgMVar *mvar = (StgMVar *)p;
 247         ASSERT(LOOKS_LIKE_PTR(mvar->head));
 248         ASSERT(LOOKS_LIKE_PTR(mvar->tail));
 249         ASSERT(LOOKS_LIKE_PTR(mvar->value));
 250 #if 0
 251 #if defined(PAR)
 252         checkBQ((StgBlockingQueueElement *)mvar->head, p);
 253 #else
 254         checkBQ(mvar->head, p);
 255 #endif
 256 #endif
 257         return sizeofW(StgMVar);
 258       }
 259
 260     case THUNK:
 261     case THUNK_1_0:
 262     case THUNK_0_1:
 263     case THUNK_1_1:
 264     case THUNK_0_2:
 265     case THUNK_2_0:
 266       {
 267         nat i;
 268         for (i = 0; i < info->layout.payload.ptrs; i++) {
 269           ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 270         }
 271         return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
 272       }
 273
 274     case BLACKHOLE_BQ:
 275       checkBQ(((StgBlockingQueue *)p)->blocking_queue, p);
 276       /* fall through to basic ptr check */
 277     case FUN:
 278     case FUN_1_0:
 279     case FUN_0_1:
 280     case FUN_1_1:
 281     case FUN_0_2:
 282     case FUN_2_0:
 283     case CONSTR:
 284     case CONSTR_1_0:
 285     case CONSTR_0_1:
 286     case CONSTR_1_1:
 287     case CONSTR_0_2:
 288     case CONSTR_2_0:
 289     case IND_PERM:
 290     case IND_OLDGEN:
 291     case IND_OLDGEN_PERM:
 292     case CAF_UNENTERED:
 293     case CAF_ENTERED:
 294     case CAF_BLACKHOLE:
 295 #ifdef TICKY_TICKY
 296     case SE_CAF_BLACKHOLE:
 297     case SE_BLACKHOLE:
 298 #endif
 299     case BLACKHOLE:
 300     case FOREIGN:
 301     case STABLE_NAME:
 302     case MUT_VAR:
 303     case CONSTR_INTLIKE:
 304     case CONSTR_CHARLIKE:
 305     case CONSTR_STATIC:
 306     case CONSTR_NOCAF_STATIC:
 307     case THUNK_STATIC:
 308     case FUN_STATIC:
 309         {
 310             nat i;
 311             for (i = 0; i < info->layout.payload.ptrs; i++) {
 312                 ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
 313             }
 314             return sizeW_fromITBL(info);
 315         }
 316
 317     case IND_STATIC: /* (1, 0) closure */
 318       ASSERT(LOOKS_LIKE_PTR(((StgIndStatic*)p)->indirectee));
 319       return sizeW_fromITBL(info);
 320
 321     case WEAK:
 322       /* deal with these specially - the info table isn't
 323        * representative of the actual layout.
 324        */
 325       { StgWeak *w = (StgWeak *)p;
 326         ASSERT(LOOKS_LIKE_PTR(w->key));
 327         ASSERT(LOOKS_LIKE_PTR(w->value));
 328         ASSERT(LOOKS_LIKE_PTR(w->finalizer));
 329         if (w->link) {
 330           ASSERT(LOOKS_LIKE_PTR(w->link));
 331         }
 332         return sizeW_fromITBL(info);
 333       }
 334
 335     case THUNK_SELECTOR:
 336             ASSERT(LOOKS_LIKE_PTR(stgCast(StgSelector*,p)->selectee));
 337             return sizeofW(StgHeader) + MIN_UPD_SIZE;
 338
 339     case IND:
 340         {
 341             /* we don't expect to see any of these after GC
 342              * but they might appear during execution
 343              */
 344             P_ q;
 345             StgInd *ind = stgCast(StgInd*,p);
 346             ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
 347             q = (P_)p + sizeofW(StgInd);
 348             while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/
 349             return q - (P_)p;
 350         }
 351
 352     case RET_BCO:
 353     case RET_SMALL:
 354     case RET_VEC_SMALL:
 355     case RET_BIG:
 356     case RET_VEC_BIG:
 357     case RET_DYN:
 358     case UPDATE_FRAME:
 359     case STOP_FRAME:
 360     case CATCH_FRAME:
 361     case SEQ_FRAME:
 362             barf("checkClosure: stack frame");
 363
 364     case AP_UPD: /* we can treat this as being the same as a PAP */
 365     case PAP:
 366         {
 367             StgPAP *pap = stgCast(StgPAP*,p);
 368             ASSERT(LOOKS_LIKE_PTR(pap->fun));
 369             checkStackChunk((StgPtr)pap->payload,
 370                             (StgPtr)pap->payload + pap->n_args
 371                             );
 372             return pap_sizeW(pap);
 373         }
 374
 375     case ARR_WORDS:
 376             return arr_words_sizeW(stgCast(StgArrWords*,p));
 377
 378     case MUT_ARR_PTRS:
 379     case MUT_ARR_PTRS_FROZEN:
 380         {
 381             StgMutArrPtrs* a = stgCast(StgMutArrPtrs*,p);
 382             nat i;
 383             for (i = 0; i < a->ptrs; i++) {
 384                 ASSERT(LOOKS_LIKE_PTR(a->payload[i]));
 385             }
 386             return mut_arr_ptrs_sizeW(a);
 387         }
 388
 389     case TSO:
 390         checkTSO((StgTSO *)p);
 391         return tso_sizeW((StgTSO *)p);
 392
 393 #if defined(PAR)
 394
 395     case BLOCKED_FETCH:
 396       ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
 397       ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
 398       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 399
 400     case FETCH_ME:
 401       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 402       return sizeofW(StgFetchMe);  // see size used in evacuate()
 403
 404     case FETCH_ME_BQ:
 405       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 406       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 407
 408     case RBH:
 409       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 410       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 411       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 412         checkBQ(((StgRBH *)p)->blocking_queue, p);
 413       ASSERT(LOOKS_LIKE_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 414       return BLACKHOLE_sizeW();   // see size used in evacuate()
 415       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 416
 417 #endif
 418
 419     case EVACUATED:
 420             barf("checkClosure: found EVACUATED closure %d",
 421                  info->type);
 422     default:
 423             barf("checkClosure (closure type %d)", info->type);
 424     }
 425 }
 426
 427 #if defined(PAR)
 428
 429 #define PVM_PE_MASK    0xfffc0000
 430 #define MAX_PVM_PES    MAX_PES
 431 #define MAX_PVM_TIDS   MAX_PES
 432 #define MAX_SLOTS      100000
 433
 434 rtsBool
 435 looks_like_tid(StgInt tid)
 436 {
 437   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 438   StgInt lo = (tid & ~PVM_PE_MASK);
 439   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 440   return ok;
 441 }
 442
 443 rtsBool
 444 looks_like_slot(StgInt slot)
 445 {
 446   /* if tid is known better use looks_like_ga!! */
 447   rtsBool ok = slot<MAX_SLOTS;
 448   // This refers only to the no. of slots on the current PE
 449   // rtsBool ok = slot<=highest_slot();
 450   return ok;
 451 }
 452
 453 rtsBool
 454 looks_like_ga(globalAddr *ga)
 455 {
 456   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 457   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 458                      (ga)->payload.gc.slot<=highest_slot() :
 459                      (ga)->payload.gc.slot<MAX_SLOTS;
 460   rtsBool ok = is_tid && is_slot;
 461   return ok;
 462 }
 463
 464 #endif
 465
 466 //@node Heap Sanity, TSO Sanity, Stack sanity
 467 //@subsection Heap Sanity
 468
 469 /* -----------------------------------------------------------------------------
 470    Check Heap Sanity
 471
 472    After garbage collection, the live heap is in a state where we can
 473    run through and check that all the pointers point to the right
 474    place.  This function starts at a given position and sanity-checks
 475    all the objects in the remainder of the chain.
 476    -------------------------------------------------------------------------- */
 477
 478 //@cindex checkHeap
 479 extern void
 480 checkHeap(bdescr *bd, StgPtr start)
 481 {
 482     StgPtr p;
 483     nat xxx = 0; // tmp -- HWL
 484
 485     if (start == NULL) {
 486       if (bd != NULL) p = bd->start;
 487     } else {
 488       p = start;
 489     }
 490
 491     while (bd != NULL) {
 492       while (p < bd->free) {
 493         nat size = checkClosure(stgCast(StgClosure*,p));
 494         /* This is the smallest size of closure that can live in the heap. */
 495         ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 496         if (get_itbl(stgCast(StgClosure*,p))->type == IND_STATIC)
 497           xxx++;
 498         p += size;
 499
 500         /* skip over slop */
 501         while (p < bd->free &&
 502                (*p == 0 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
 503       }
 504       bd = bd->link;
 505       if (bd != NULL) {
 506         p = bd->start;
 507       }
 508     }
 509     fprintf(stderr,"@@@@ checkHeap: Heap ok; %d IND_STATIC closures checked\n",
 510             xxx);
 511 }
 512
 513 /*
 514    Check heap between start and end. Used after unpacking graphs.
 515 */
 516 extern void
 517 checkHeapChunk(StgPtr start, StgPtr end)
 518 {
 519   StgPtr p;
 520   nat size;
 521
 522   for (p=start; p<end; p+=size) {
 523     ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
 524     size = checkClosure(stgCast(StgClosure*,p));
 525     /* This is the smallest size of closure that can live in the heap. */
 526     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 527   }
 528 }
 529
 530 //@cindex checkChain
 531 extern void
 532 checkChain(bdescr *bd)
 533 {
 534   while (bd != NULL) {
 535     checkClosure((StgClosure *)bd->start);
 536     bd = bd->link;
 537   }
 538 }
 539
 540 /* check stack - making sure that update frames are linked correctly */
 541 //@cindex checkStack
 542 void
 543 checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
 544 {
 545     /* check everything down to the first update frame */
 546     checkStackChunk( sp, stgCast(StgPtr,su) );
 547     while ( stgCast(StgPtr,su) < stack_end) {
 548         sp = stgCast(StgPtr,su);
 549         switch (get_itbl(su)->type) {
 550         case UPDATE_FRAME:
 551                 su = su->link;
 552                 break;
 553         case SEQ_FRAME:
 554                 su = stgCast(StgSeqFrame*,su)->link;
 555                 break;
 556         case CATCH_FRAME:
 557                 su = stgCast(StgCatchFrame*,su)->link;
 558                 break;
 559         case STOP_FRAME:
 560                 /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */
 561                 return;
 562         default:
 563                 barf("checkStack: weird record found on update frame list.");
 564         }
 565         checkStackChunk( sp, stgCast(StgPtr,su) );
 566     }
 567     ASSERT(stgCast(StgPtr,su) == stack_end);
 568 }
 569
 570 //@node TSO Sanity, Thread Queue Sanity, Heap Sanity
 571 //@subsection TSO Sanity
 572
 573 //@cindex checkTSO
 574 extern void
 575 checkTSO(StgTSO *tso)
 576 {
 577     StgPtr sp = tso->sp;
 578     StgPtr stack = tso->stack;
 579     StgUpdateFrame* su = tso->su;
 580     StgOffset stack_size = tso->stack_size;
 581     StgPtr stack_end = stack + stack_size;
 582
 583     if (tso->what_next == ThreadRelocated) {
 584       checkTSO(tso->link);
 585       return;
 586     }
 587
 588     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
 589       /* The garbage collector doesn't bother following any pointers
 590        * from dead threads, so don't check sanity here.
 591        */
 592       return;
 593     }
 594
 595     ASSERT(stack <= sp && sp < stack_end);
 596     ASSERT(sp <= stgCast(StgPtr,su));
 597
 598 #if defined(PAR)
 599     ASSERT(tso->par.magic==TSO_MAGIC);
 600
 601     switch (tso->why_blocked) {
 602     case BlockedOnGA:
 603       checkClosureShallow(tso->block_info.closure);
 604       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 605              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 606       break;
 607     case BlockedOnGA_NoSend:
 608       checkClosureShallow(tso->block_info.closure);
 609       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 610       break;
 611     case BlockedOnBlackHole:
 612       checkClosureShallow(tso->block_info.closure);
 613       ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
 614              get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
 615              get_itbl(tso->block_info.closure)->type==RBH);
 616       break;
 617     case BlockedOnRead:
 618     case BlockedOnWrite:
 619     case BlockedOnDelay:
 620       /* isOnBQ(blocked_queue) */
 621       break;
 622     case BlockedOnException:
 623       /* isOnSomeBQ(tso) */
 624       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 625       break;
 626     case BlockedOnMVar:
 627       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 628       break;
 629     default:
 630       /*
 631          Could check other values of why_blocked but I am more
 632          lazy than paranoid (bad combination) -- HWL
 633       */
 634     }
 635
 636     /* if the link field is non-nil it most point to one of these
 637        three closure types */
 638     ASSERT(tso->link == END_TSO_QUEUE ||
 639            get_itbl(tso->link)->type == TSO ||
 640            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 641            get_itbl(tso->link)->type == CONSTR);
 642 #endif
 643
 644     checkStack(sp, stack_end, su);
 645 }
 646
 647 #if defined(GRAN)
 648 //@cindex checkTSOsSanity
 649 extern void
 650 checkTSOsSanity(void) {
 651   nat i, tsos;
 652   StgTSO *tso;
 653
 654   belch("Checking sanity of all runnable TSOs:");
 655
 656   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 657     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 658       fprintf(stderr, "TSO %p on PE %d ...", tso, i);
 659       checkTSO(tso);
 660       fprintf(stderr, "OK, ");
 661       tsos++;
 662     }
 663   }
 664
 665   belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 666 }
 667
 668 //@node Thread Queue Sanity, Blackhole Sanity, TSO Sanity
 669 //@subsection Thread Queue Sanity
 670
 671 // still GRAN only
 672
 673 //@cindex checkThreadQSanity
 674 extern rtsBool
 675 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 676 {
 677   StgTSO *tso, *prev;
 678
 679   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 680   ASSERT(run_queue_hds[proc]!=NULL);
 681   ASSERT(run_queue_tls[proc]!=NULL);
 682   /* if either head or tail is NIL then the other one must be NIL, too */
 683   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 684   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 685   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 686        tso!=END_TSO_QUEUE;
 687        prev=tso, tso=tso->link) {
 688     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 689            (prev==END_TSO_QUEUE || prev->link==tso));
 690     if (check_TSO_too)
 691       checkTSO(tso);
 692   }
 693   ASSERT(prev==run_queue_tls[proc]);
 694 }
 695
 696 //@cindex checkThreadQsSanity
 697 extern rtsBool
 698 checkThreadQsSanity (rtsBool check_TSO_too)
 699 {
 700   PEs p;
 701
 702   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 703     checkThreadQSanity(p, check_TSO_too);
 704 }
 705 #endif /* GRAN */
 706
 707 /*
 708    Check that all TSOs have been evacuated.
 709    Optionally also check the sanity of the TSOs.
 710 */
 711 void
 712 checkGlobalTSOList (rtsBool checkTSOs)
 713 {
 714   extern  StgTSO *all_threads;
 715   StgTSO *tso;
 716   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 717     ASSERT(Bdescr((P_)tso)->evacuated == 1);
 718     if (checkTSOs)
 719       checkTSO(tso);
 720   }
 721 }
 722
 723 //@node Blackhole Sanity, GALA table sanity, Thread Queue Sanity
 724 //@subsection Blackhole Sanity
 725
 726 /* -----------------------------------------------------------------------------
 727    Check Blackhole Sanity
 728
 729    Test whether an object is already on the update list.
 730    It isn't necessarily an rts error if it is - it might be a programming
 731    error.
 732
 733    Future versions might be able to test for a blackhole without traversing
 734    the update frame list.
 735
 736    -------------------------------------------------------------------------- */
 737 //@cindex isBlackhole
 738 rtsBool
 739 isBlackhole( StgTSO* tso, StgClosure* p )
 740 {
 741   StgUpdateFrame* su = tso->su;
 742   do {
 743     switch (get_itbl(su)->type) {
 744     case UPDATE_FRAME:
 745       if (su->updatee == p) {
 746         return rtsTrue;
 747       } else {
 748         su = su->link;
 749       }
 750       break;
 751     case SEQ_FRAME:
 752       su = stgCast(StgSeqFrame*,su)->link;
 753       break;
 754     case CATCH_FRAME:
 755       su = stgCast(StgCatchFrame*,su)->link;
 756       break;
 757     case STOP_FRAME:
 758       return rtsFalse;
 759     default:
 760       barf("isBlackhole: weird record found on update frame list.");
 761     }
 762   } while (1);
 763 }
 764
 765 /*
 766   Check the static objects list.
 767 */
 768 extern void
 769 checkStaticObjects ( void ) {
 770   extern StgClosure* static_objects;
 771   StgClosure *p = static_objects;
 772   StgInfoTable *info;
 773
 774   while (p != END_OF_STATIC_LIST) {
 775     checkClosure(p);
 776     info = get_itbl(p);
 777     switch (info->type) {
 778     case IND_STATIC:
 779       {
 780         StgClosure *indirectee = stgCast(StgIndStatic*,p)->indirectee;
 781
 782         ASSERT(LOOKS_LIKE_PTR(indirectee));
 783         ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info));
 784         p = IND_STATIC_LINK((StgClosure *)p);
 785         break;
 786       }
 787
 788     case THUNK_STATIC:
 789       p = THUNK_STATIC_LINK((StgClosure *)p);
 790       break;
 791
 792     case FUN_STATIC:
 793       p = FUN_STATIC_LINK((StgClosure *)p);
 794       break;
 795
 796     case CONSTR_STATIC:
 797       p = STATIC_LINK(info,(StgClosure *)p);
 798       break;
 799
 800     default:
 801       barf("checkStaticObjetcs: strange closure %p (%s)",
 802            p, info_type(p));
 803     }
 804   }
 805 }
 806
 807 /*
 808    Check the sanity of a blocking queue starting at bqe with closure being
 809    the closure holding the blocking queue.
 810    Note that in GUM we can have several different closure types in a
 811    blocking queue
 812 */
 813 //@cindex checkBQ
 814 #if defined(PAR)
 815 void
 816 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 817 {
 818   rtsBool end = rtsFalse;
 819   StgInfoTable *info = get_itbl(closure);
 820
 821   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR
 822          || info->type == FETCH_ME_BQ || info->type == RBH);
 823
 824   do {
 825     switch (get_itbl(bqe)->type) {
 826     case BLOCKED_FETCH:
 827     case TSO:
 828       checkClosure((StgClosure *)bqe);
 829       bqe = bqe->link;
 830       end = (bqe==END_BQ_QUEUE);
 831       break;
 832
 833     case CONSTR:
 834       checkClosure((StgClosure *)bqe);
 835       end = rtsTrue;
 836       break;
 837
 838     default:
 839       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 840            get_itbl(bqe)->type, closure, info_type(closure));
 841     }
 842   } while (!end);
 843 }
 844 #elif defined(GRAN)
 845 void
 846 checkBQ (StgTSO *bqe, StgClosure *closure)
 847 {
 848   rtsBool end = rtsFalse;
 849   StgInfoTable *info = get_itbl(closure);
 850
 851   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 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     default:
 863       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 864            get_itbl(bqe)->type, closure, info_type(closure));
 865     }
 866   } while (!end);
 867 }
 868 #else
 869 void
 870 checkBQ (StgTSO *bqe, StgClosure *closure)
 871 {
 872   rtsBool end = rtsFalse;
 873   StgInfoTable *info = get_itbl(closure);
 874
 875   ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
 876
 877   do {
 878     switch (get_itbl(bqe)->type) {
 879     case TSO:
 880       checkClosure((StgClosure *)bqe);
 881       bqe = bqe->link;
 882       end = (bqe==END_TSO_QUEUE);
 883       break;
 884
 885     default:
 886       barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
 887            get_itbl(bqe)->type, closure, info->type);
 888     }
 889   } while (!end);
 890 }
 891
 892 #endif
 893
 894
 895 //@node GALA table sanity, Index, Blackhole Sanity
 896 //@subsection GALA table sanity
 897
 898 /*
 899   This routine checks the sanity of the LAGA and GALA tables. They are
 900   implemented as lists through one hash table, LAtoGALAtable, because entries
 901   in both tables have the same structure:
 902    - the LAGA table maps local addresses to global addresses; it starts
 903      with liveIndirections
 904    - the GALA table maps global addresses to local addresses; it starts
 905      with liveRemoteGAs
 906 */
 907
 908 #if defined(PAR)
 909 #include "Hash.h"
 910
 911 /* hidden in parallel/Global.c; only accessed for testing here */
 912 extern GALA *liveIndirections;
 913 extern GALA *liveRemoteGAs;
 914 extern HashTable *LAtoGALAtable;
 915
 916 //@cindex checkLAGAtable
 917 void
 918 checkLAGAtable(rtsBool check_closures)
 919 {
 920   GALA *gala, *gala0;
 921   nat n=0, m=0; // debugging
 922
 923   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 924     n++;
 925     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 926     ASSERT(!gala->preferred || gala == gala0);
 927     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 928     ASSERT(gala->next!=gala); // detect direct loops
 929     /*
 930     if ( check_closures ) {
 931       checkClosure(stgCast(StgClosure*,gala->la));
 932     }
 933     */
 934   }
 935
 936   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 937     m++;
 938     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 939     ASSERT(!gala->preferred || gala == gala0);
 940     ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
 941     ASSERT(gala->next!=gala); // detect direct loops
 942     /*
 943     if ( check_closures ) {
 944       checkClosure(stgCast(StgClosure*,gala->la));
 945     }
 946     */
 947   }
 948 }
 949 #endif
 950
 951 //@node Index,  , GALA table sanity
 952 //@subsection Index
 953
 954 #endif /* DEBUG */
 955
 956 //@index
 957 //* checkBQ::  @cindex\s-+checkBQ
 958 //* checkChain::  @cindex\s-+checkChain
 959 //* checkClosureShallow::  @cindex\s-+checkClosureShallow
 960 //* checkHeap::  @cindex\s-+checkHeap
 961 //* checkLargeBitmap::  @cindex\s-+checkLargeBitmap
 962 //* checkSmallBitmap::  @cindex\s-+checkSmallBitmap
 963 //* checkStack::  @cindex\s-+checkStack
 964 //* checkStackChunk::  @cindex\s-+checkStackChunk
 965 //* checkStackChunk::  @cindex\s-+checkStackChunk
 966 //* checkStackClosure::  @cindex\s-+checkStackClosure
 967 //* checkStackObject::  @cindex\s-+checkStackObject
 968 //* checkTSO::  @cindex\s-+checkTSO
 969 //* checkTSOsSanity::  @cindex\s-+checkTSOsSanity
 970 //* checkThreadQSanity::  @cindex\s-+checkThreadQSanity
 971 //* checkThreadQsSanity::  @cindex\s-+checkThreadQsSanity
 972 //* isBlackhole::  @cindex\s-+isBlackhole
 973 //@end index