ghc/rts/Sanity.c

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