ghc/rts/Sanity.c

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