ghc/rts/Sanity.c

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