rts/Sanity.c

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