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             StgInd *ind = (StgInd *)p;
 360             ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
 361             return sizeofW(StgHeader) + MIN_UPD_SIZE;
 362         }
 363
 364     case RET_BCO:
 365     case RET_SMALL:
 366     case RET_VEC_SMALL:
 367     case RET_BIG:
 368     case RET_VEC_BIG:
 369     case RET_DYN:
 370     case UPDATE_FRAME:
 371     case STOP_FRAME:
 372     case CATCH_FRAME:
 373     case ATOMICALLY_FRAME:
 374     case CATCH_RETRY_FRAME:
 375     case CATCH_STM_FRAME:
 376             barf("checkClosure: stack frame");
 377
 378     case AP:
 379     {
 380         StgAP* ap = (StgAP *)p;
 381         checkPAP (ap->fun, ap->payload, ap->n_args);
 382         return ap_sizeW(ap);
 383     }
 384
 385     case PAP:
 386     {
 387         StgPAP* pap = (StgPAP *)p;
 388         checkPAP (pap->fun, pap->payload, pap->n_args);
 389         return pap_sizeW(pap);
 390     }
 391
 392     case AP_STACK:
 393     {
 394         StgAP_STACK *ap = (StgAP_STACK *)p;
 395         ASSERT(LOOKS_LIKE_CLOSURE_PTR(ap->fun));
 396         checkStackChunk((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
 397         return ap_stack_sizeW(ap);
 398     }
 399
 400     case ARR_WORDS:
 401             return arr_words_sizeW((StgArrWords *)p);
 402
 403     case MUT_ARR_PTRS:
 404     case MUT_ARR_PTRS_FROZEN:
 405     case MUT_ARR_PTRS_FROZEN0:
 406         {
 407             StgMutArrPtrs* a = (StgMutArrPtrs *)p;
 408             nat i;
 409             for (i = 0; i < a->ptrs; i++) {
 410                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
 411             }
 412             return mut_arr_ptrs_sizeW(a);
 413         }
 414
 415     case TSO:
 416         checkTSO((StgTSO *)p);
 417         return tso_sizeW((StgTSO *)p);
 418
 419 #if defined(PAR)
 420
 421     case BLOCKED_FETCH:
 422       ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
 423       ASSERT(LOOKS_LIKE_CLOSURE_PTR((((StgBlockedFetch *)p)->node)));
 424       return sizeofW(StgBlockedFetch);  // see size used in evacuate()
 425
 426 #ifdef DIST
 427     case REMOTE_REF:
 428       return sizeofW(StgFetchMe);
 429 #endif /*DIST */
 430
 431     case FETCH_ME:
 432       ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
 433       return sizeofW(StgFetchMe);  // see size used in evacuate()
 434
 435     case FETCH_ME_BQ:
 436       checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
 437       return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
 438
 439     case RBH:
 440       /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
 441       ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
 442       if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
 443         checkBQ(((StgRBH *)p)->blocking_queue, p);
 444       ASSERT(LOOKS_LIKE_INFO_PTR(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
 445       return BLACKHOLE_sizeW();   // see size used in evacuate()
 446       // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
 447
 448 #endif
 449
 450     case TVAR_WAIT_QUEUE:
 451       {
 452         StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
 453         ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->next_queue_entry));
 454         ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->prev_queue_entry));
 455         return sizeofW(StgTVarWaitQueue);
 456       }
 457
 458     case TVAR:
 459       {
 460         StgTVar *tv = (StgTVar *)p;
 461         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->current_value));
 462         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->first_wait_queue_entry));
 463         return sizeofW(StgTVar);
 464       }
 465
 466     case TREC_CHUNK:
 467       {
 468         nat i;
 469         StgTRecChunk *tc = (StgTRecChunk *)p;
 470         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->prev_chunk));
 471         for (i = 0; i < tc -> next_entry_idx; i ++) {
 472           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].tvar));
 473           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].expected_value));
 474           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].new_value));
 475         }
 476         return sizeofW(StgTRecChunk);
 477       }
 478
 479     case TREC_HEADER:
 480       {
 481         StgTRecHeader *trec = (StgTRecHeader *)p;
 482         ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> enclosing_trec));
 483         ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> current_chunk));
 484         return sizeofW(StgTRecHeader);
 485       }
 486
 487
 488     case EVACUATED:
 489             barf("checkClosure: found EVACUATED closure %d",
 490                  info->type);
 491     default:
 492             barf("checkClosure (closure type %d)", info->type);
 493     }
 494 }
 495
 496 #if defined(PAR)
 497
 498 #define PVM_PE_MASK    0xfffc0000
 499 #define MAX_PVM_PES    MAX_PES
 500 #define MAX_PVM_TIDS   MAX_PES
 501 #define MAX_SLOTS      100000
 502
 503 rtsBool
 504 looks_like_tid(StgInt tid)
 505 {
 506   StgInt hi = (tid & PVM_PE_MASK) >> 18;
 507   StgInt lo = (tid & ~PVM_PE_MASK);
 508   rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
 509   return ok;
 510 }
 511
 512 rtsBool
 513 looks_like_slot(StgInt slot)
 514 {
 515   /* if tid is known better use looks_like_ga!! */
 516   rtsBool ok = slot<MAX_SLOTS;
 517   // This refers only to the no. of slots on the current PE
 518   // rtsBool ok = slot<=highest_slot();
 519   return ok;
 520 }
 521
 522 rtsBool
 523 looks_like_ga(globalAddr *ga)
 524 {
 525   rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
 526   rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
 527                      (ga)->payload.gc.slot<=highest_slot() :
 528                      (ga)->payload.gc.slot<MAX_SLOTS;
 529   rtsBool ok = is_tid && is_slot;
 530   return ok;
 531 }
 532
 533 #endif
 534
 535
 536 /* -----------------------------------------------------------------------------
 537    Check Heap Sanity
 538
 539    After garbage collection, the live heap is in a state where we can
 540    run through and check that all the pointers point to the right
 541    place.  This function starts at a given position and sanity-checks
 542    all the objects in the remainder of the chain.
 543    -------------------------------------------------------------------------- */
 544
 545 void
 546 checkHeap(bdescr *bd)
 547 {
 548     StgPtr p;
 549
 550     for (; bd != NULL; bd = bd->link) {
 551         p = bd->start;
 552         while (p < bd->free) {
 553             nat size = checkClosure((StgClosure *)p);
 554             /* This is the smallest size of closure that can live in the heap */
 555             ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 556             p += size;
 557
 558             /* skip over slop */
 559             while (p < bd->free &&
 560                    (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR((void*)*p))) { p++; }
 561         }
 562     }
 563 }
 564
 565 #if defined(PAR)
 566 /*
 567    Check heap between start and end. Used after unpacking graphs.
 568 */
 569 void
 570 checkHeapChunk(StgPtr start, StgPtr end)
 571 {
 572   extern globalAddr *LAGAlookup(StgClosure *addr);
 573   StgPtr p;
 574   nat size;
 575
 576   for (p=start; p<end; p+=size) {
 577     ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
 578     if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
 579         *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
 580       /* if it's a FM created during unpack and commoned up, it's not global */
 581       ASSERT(LAGAlookup((StgClosure*)p)==NULL);
 582       size = sizeofW(StgFetchMe);
 583     } else if (get_itbl((StgClosure*)p)->type == IND) {
 584       *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
 585       size = MIN_UPD_SIZE;
 586     } else {
 587       size = checkClosure((StgClosure *)p);
 588       /* This is the smallest size of closure that can live in the heap. */
 589       ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 590     }
 591   }
 592 }
 593 #else /* !PAR */
 594 void
 595 checkHeapChunk(StgPtr start, StgPtr end)
 596 {
 597   StgPtr p;
 598   nat size;
 599
 600   for (p=start; p<end; p+=size) {
 601     ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
 602     size = checkClosure((StgClosure *)p);
 603     /* This is the smallest size of closure that can live in the heap. */
 604     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 605   }
 606 }
 607 #endif
 608
 609 void
 610 checkChain(bdescr *bd)
 611 {
 612   while (bd != NULL) {
 613     checkClosure((StgClosure *)bd->start);
 614     bd = bd->link;
 615   }
 616 }
 617
 618 void
 619 checkTSO(StgTSO *tso)
 620 {
 621     StgPtr sp = tso->sp;
 622     StgPtr stack = tso->stack;
 623     StgOffset stack_size = tso->stack_size;
 624     StgPtr stack_end = stack + stack_size;
 625
 626     if (tso->what_next == ThreadRelocated) {
 627       checkTSO(tso->link);
 628       return;
 629     }
 630
 631     if (tso->what_next == ThreadKilled) {
 632       /* The garbage collector doesn't bother following any pointers
 633        * from dead threads, so don't check sanity here.
 634        */
 635       return;
 636     }
 637
 638     ASSERT(stack <= sp && sp < stack_end);
 639
 640 #if defined(PAR)
 641     ASSERT(tso->par.magic==TSO_MAGIC);
 642
 643     switch (tso->why_blocked) {
 644     case BlockedOnGA:
 645       checkClosureShallow(tso->block_info.closure);
 646       ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
 647              get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 648       break;
 649     case BlockedOnGA_NoSend:
 650       checkClosureShallow(tso->block_info.closure);
 651       ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
 652       break;
 653     case BlockedOnBlackHole:
 654       checkClosureShallow(tso->block_info.closure);
 655       ASSERT(get_itbl(tso->block_info.closure)->type==BLACKHOLE ||
 656              get_itbl(tso->block_info.closure)->type==RBH);
 657       break;
 658     case BlockedOnRead:
 659     case BlockedOnWrite:
 660     case BlockedOnDelay:
 661 #if defined(mingw32_HOST_OS)
 662     case BlockedOnDoProc:
 663 #endif
 664       /* isOnBQ(blocked_queue) */
 665       break;
 666     case BlockedOnException:
 667       /* isOnSomeBQ(tso) */
 668       ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
 669       break;
 670     case BlockedOnMVar:
 671       ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
 672       break;
 673     case BlockedOnSTM:
 674       ASSERT(tso->block_info.closure == END_TSO_QUEUE);
 675       break;
 676     default:
 677       /*
 678          Could check other values of why_blocked but I am more
 679          lazy than paranoid (bad combination) -- HWL
 680       */
 681     }
 682
 683     /* if the link field is non-nil it most point to one of these
 684        three closure types */
 685     ASSERT(tso->link == END_TSO_QUEUE ||
 686            get_itbl(tso->link)->type == TSO ||
 687            get_itbl(tso->link)->type == BLOCKED_FETCH ||
 688            get_itbl(tso->link)->type == CONSTR);
 689 #endif
 690
 691     checkStackChunk(sp, stack_end);
 692 }
 693
 694 #if defined(GRAN)
 695 void
 696 checkTSOsSanity(void) {
 697   nat i, tsos;
 698   StgTSO *tso;
 699
 700   debugBelch("Checking sanity of all runnable TSOs:");
 701
 702   for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
 703     for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
 704       debugBelch("TSO %p on PE %d ...", tso, i);
 705       checkTSO(tso);
 706       debugBelch("OK, ");
 707       tsos++;
 708     }
 709   }
 710
 711   debugBelch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
 712 }
 713
 714
 715 // still GRAN only
 716
 717 rtsBool
 718 checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
 719 {
 720   StgTSO *tso, *prev;
 721
 722   /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
 723   ASSERT(run_queue_hds[proc]!=NULL);
 724   ASSERT(run_queue_tls[proc]!=NULL);
 725   /* if either head or tail is NIL then the other one must be NIL, too */
 726   ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
 727   ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
 728   for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
 729        tso!=END_TSO_QUEUE;
 730        prev=tso, tso=tso->link) {
 731     ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
 732            (prev==END_TSO_QUEUE || prev->link==tso));
 733     if (check_TSO_too)
 734       checkTSO(tso);
 735   }
 736   ASSERT(prev==run_queue_tls[proc]);
 737 }
 738
 739 rtsBool
 740 checkThreadQsSanity (rtsBool check_TSO_too)
 741 {
 742   PEs p;
 743
 744   for (p=0; p<RtsFlags.GranFlags.proc; p++)
 745     checkThreadQSanity(p, check_TSO_too);
 746 }
 747 #endif /* GRAN */
 748
 749 /*
 750    Check that all TSOs have been evacuated.
 751    Optionally also check the sanity of the TSOs.
 752 */
 753 void
 754 checkGlobalTSOList (rtsBool checkTSOs)
 755 {
 756   extern  StgTSO *all_threads;
 757   StgTSO *tso;
 758   for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
 759       ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
 760       ASSERT(get_itbl(tso)->type == TSO);
 761       if (checkTSOs)
 762           checkTSO(tso);
 763   }
 764 }
 765
 766 /* -----------------------------------------------------------------------------
 767    Check mutable list sanity.
 768    -------------------------------------------------------------------------- */
 769
 770 void
 771 checkMutableList( bdescr *mut_bd, nat gen )
 772 {
 773     bdescr *bd;
 774     StgPtr q;
 775     StgClosure *p;
 776
 777     for (bd = mut_bd; bd != NULL; bd = bd->link) {
 778         for (q = bd->start; q < bd->free; q++) {
 779             p = (StgClosure *)*q;
 780             ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
 781         }
 782     }
 783 }
 784
 785 /*
 786   Check the static objects list.
 787 */
 788 void
 789 checkStaticObjects ( StgClosure* static_objects )
 790 {
 791   StgClosure *p = static_objects;
 792   StgInfoTable *info;
 793
 794   while (p != END_OF_STATIC_LIST) {
 795     checkClosure(p);
 796     info = get_itbl(p);
 797     switch (info->type) {
 798     case IND_STATIC:
 799       {
 800         StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
 801
 802         ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
 803         ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
 804         p = *IND_STATIC_LINK((StgClosure *)p);
 805         break;
 806       }
 807
 808     case THUNK_STATIC:
 809       p = *THUNK_STATIC_LINK((StgClosure *)p);
 810       break;
 811
 812     case FUN_STATIC:
 813       p = *FUN_STATIC_LINK((StgClosure *)p);
 814       break;
 815
 816     case CONSTR_STATIC:
 817       p = *STATIC_LINK(info,(StgClosure *)p);
 818       break;
 819
 820     default:
 821       barf("checkStaticObjetcs: strange closure %p (%s)",
 822            p, info_type(p));
 823     }
 824   }
 825 }
 826
 827 /*
 828    Check the sanity of a blocking queue starting at bqe with closure being
 829    the closure holding the blocking queue.
 830    Note that in GUM we can have several different closure types in a
 831    blocking queue
 832 */
 833 #if defined(PAR)
 834 void
 835 checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
 836 {
 837   rtsBool end = rtsFalse;
 838   StgInfoTable *info = get_itbl(closure);
 839
 840   ASSERT(info->type == MVAR || info->type == FETCH_ME_BQ || info->type == RBH);
 841
 842   do {
 843     switch (get_itbl(bqe)->type) {
 844     case BLOCKED_FETCH:
 845     case TSO:
 846       checkClosure((StgClosure *)bqe);
 847       bqe = bqe->link;
 848       end = (bqe==END_BQ_QUEUE);
 849       break;
 850
 851     case CONSTR:
 852       checkClosure((StgClosure *)bqe);
 853       end = rtsTrue;
 854       break;
 855
 856     default:
 857       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 858            get_itbl(bqe)->type, closure, info_type(closure));
 859     }
 860   } while (!end);
 861 }
 862 #elif defined(GRAN)
 863 void
 864 checkBQ (StgTSO *bqe, StgClosure *closure)
 865 {
 866   rtsBool end = rtsFalse;
 867   StgInfoTable *info = get_itbl(closure);
 868
 869   ASSERT(info->type == MVAR);
 870
 871   do {
 872     switch (get_itbl(bqe)->type) {
 873     case BLOCKED_FETCH:
 874     case TSO:
 875       checkClosure((StgClosure *)bqe);
 876       bqe = bqe->link;
 877       end = (bqe==END_BQ_QUEUE);
 878       break;
 879
 880     default:
 881       barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
 882            get_itbl(bqe)->type, closure, info_type(closure));
 883     }
 884   } while (!end);
 885 }
 886 #endif
 887
 888
 889
 890 /*
 891   This routine checks the sanity of the LAGA and GALA tables. They are
 892   implemented as lists through one hash table, LAtoGALAtable, because entries
 893   in both tables have the same structure:
 894    - the LAGA table maps local addresses to global addresses; it starts
 895      with liveIndirections
 896    - the GALA table maps global addresses to local addresses; it starts
 897      with liveRemoteGAs
 898 */
 899
 900 #if defined(PAR)
 901 #include "Hash.h"
 902
 903 /* hidden in parallel/Global.c; only accessed for testing here */
 904 extern GALA *liveIndirections;
 905 extern GALA *liveRemoteGAs;
 906 extern HashTable *LAtoGALAtable;
 907
 908 void
 909 checkLAGAtable(rtsBool check_closures)
 910 {
 911   GALA *gala, *gala0;
 912   nat n=0, m=0; // debugging
 913
 914   for (gala = liveIndirections; gala != NULL; gala = gala->next) {
 915     n++;
 916     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 917     ASSERT(!gala->preferred || gala == gala0);
 918     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 919     ASSERT(gala->next!=gala); // detect direct loops
 920     if ( check_closures ) {
 921       checkClosure((StgClosure *)gala->la);
 922     }
 923   }
 924
 925   for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
 926     m++;
 927     gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
 928     ASSERT(!gala->preferred || gala == gala0);
 929     ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
 930     ASSERT(gala->next!=gala); // detect direct loops
 931     /*
 932     if ( check_closures ) {
 933       checkClosure((StgClosure *)gala->la);
 934     }
 935     */
 936   }
 937 }
 938 #endif
 939
 940 #endif /* DEBUG */