X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FSanity.c;h=ab2254d8351674d0827c390272ff2a734e55925d;hb=97906cfcc30dd591e840921d336fdabeb1b8a315;hp=28bc43257ae8af2353451c76b73fbb00ed35c8b8;hpb=eb407ca1d21a43ff86ad731868f71e994afafe78;p=ghc-hetmet.git diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c index 28bc432..ab2254d 100644 --- a/ghc/rts/Sanity.c +++ b/ghc/rts/Sanity.c @@ -1,11 +1,11 @@ /* ----------------------------------------------------------------------------- - * $Id: Sanity.c,v 1.13 1999/05/11 16:47:57 keithw Exp $ + * $Id: Sanity.c,v 1.30 2001/08/14 13:40:09 sewardj Exp $ * - * (c) The GHC Team, 1998-1999 + * (c) The GHC Team, 1998-2001 * * Sanity checking code for the heap and stack. * - * Used when debugging: check that the stack looks reasonable. + * Used when debugging: check that everything reasonable. * * - All things that are supposed to be pointers look like pointers. * @@ -14,68 +14,93 @@ * * ---------------------------------------------------------------------------*/ +#include "PosixSource.h" #include "Rts.h" -#ifdef DEBUG +#ifdef DEBUG /* whole file */ #include "RtsFlags.h" #include "RtsUtils.h" #include "BlockAlloc.h" #include "Sanity.h" - -#define LOOKS_LIKE_PTR(r) (IS_DATA_PTR(r) || ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) +#include "MBlock.h" +#include "Storage.h" +#include "Schedule.h" +#include "StoragePriv.h" // for END_OF_STATIC_LIST /* ----------------------------------------------------------------------------- - Check stack sanity - -------------------------------------------------------------------------- */ + A valid pointer is either: -StgOffset checkStackClosure( StgClosure* c ); + - a pointer to a static closure, or + - a pointer into the heap, and + - the block is not free + - either: - the object is large, or + - it is not after the free pointer in the block + - the contents of the pointer is not 0xaaaaaaaa -StgOffset checkStackObject( StgPtr sp ); + -------------------------------------------------------------------------- */ + +#define LOOKS_LIKE_PTR(r) \ + ({ bdescr *bd = Bdescr((P_)r); \ + LOOKS_LIKE_STATIC_CLOSURE(r) || \ + (HEAP_ALLOCED(r) \ + && bd != (void *)-1 \ + && ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa) \ + ); \ + }) -void checkStackChunk( StgPtr sp, StgPtr stack_end ); +// NOT always true, but can be useful for spotting bugs: (generally +// true after GC, but not for things just allocated using allocate(), +// for example): +// (bd->flags & BF_LARGE || bd->free > (P_)r) -static StgOffset checkSmallBitmap( StgPtr payload, StgWord32 bitmap ); +/* ----------------------------------------------------------------------------- + Forward decls. + -------------------------------------------------------------------------- */ -static StgOffset checkLargeBitmap( StgPtr payload, - StgLargeBitmap* large_bitmap ); +static StgOffset checkStackClosure ( StgClosure* c ); +static StgOffset checkStackObject ( StgPtr sp ); +static StgOffset checkSmallBitmap ( StgPtr payload, StgWord bitmap ); +static StgOffset checkLargeBitmap ( StgPtr payload, StgLargeBitmap* ); +static void checkClosureShallow ( StgClosure* p ); -void checkClosureShallow( StgClosure* p ); +/* ----------------------------------------------------------------------------- + Check stack sanity + -------------------------------------------------------------------------- */ static StgOffset -checkSmallBitmap( StgPtr payload, StgWord32 bitmap ) +checkSmallBitmap( StgPtr payload, StgWord bitmap ) { StgOffset i; i = 0; for(; bitmap != 0; ++i, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { - checkClosure(stgCast(StgClosure*,payload[i])); + checkClosure((StgClosure *)payload[i]); } } return i; } - static StgOffset checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap ) { - StgWord32 bmp; + StgWord bmp; StgOffset i; i = 0; for (bmp=0; bmpsize; bmp++) { - StgWord32 bitmap = large_bitmap->bitmap[bmp]; + StgWord bitmap = large_bitmap->bitmap[bmp]; for(; bitmap != 0; ++i, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { - checkClosure(stgCast(StgClosure*,payload[i])); + checkClosure((StgClosure *)payload[i]); } } } return i; } -StgOffset +static StgOffset checkStackClosure( StgClosure* c ) { const StgInfoTable* info = get_itbl(c); @@ -91,17 +116,35 @@ checkStackClosure( StgClosure* c ) case RET_BCO: /* small bitmap (<= 32 entries) */ case RET_SMALL: case RET_VEC_SMALL: + return 1 + checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap); + case UPDATE_FRAME: + ASSERT(LOOKS_LIKE_PTR(((StgUpdateFrame*)c)->updatee)); case CATCH_FRAME: - case STOP_FRAME: case SEQ_FRAME: - return 1 + checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap); + /* check that the link field points to another stack frame */ + ASSERT(get_itbl(((StgFrame*)c)->link)->type == UPDATE_FRAME || + get_itbl(((StgFrame*)c)->link)->type == CATCH_FRAME || + get_itbl(((StgFrame*)c)->link)->type == STOP_FRAME || + get_itbl(((StgFrame*)c)->link)->type == SEQ_FRAME); + /* fall through */ + case STOP_FRAME: +#if defined(GRAN) + return 2 + +#else + return 1 + +#endif + checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap); case RET_BIG: /* large bitmap (> 32 entries) */ case RET_VEC_BIG: return 1 + checkLargeBitmap((StgPtr)c + 1,info->layout.large_bitmap); case FUN: case FUN_STATIC: /* probably a slow-entry point return address: */ - return 1; +#if 0 && defined(GRAN) + return 2; +#else + return 1; +#endif default: /* if none of the above, maybe it's a closure which looks a * little like an infotable @@ -121,7 +164,9 @@ checkStackClosure( StgClosure* c ) void checkClosureShallow( StgClosure* p ) { - ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info)); + ASSERT(p); + ASSERT(LOOKS_LIKE_GHC_INFO(GET_INFO(p)) + || IS_HUGS_CONSTR_INFO(GET_INFO(p))); /* Is it a static closure (i.e. in the data segment)? */ if (LOOKS_LIKE_STATIC(p)) { @@ -132,25 +177,24 @@ checkClosureShallow( StgClosure* p ) } } -/* check an individual stack object */ +// check an individual stack object StgOffset checkStackObject( StgPtr sp ) { if (IS_ARG_TAG(*sp)) { - /* Tagged words might be "stubbed" pointers, so there's no - * point checking to see whether they look like pointers or - * not (some of them will). - */ + // Tagged words might be "stubbed" pointers, so there's no + // point checking to see whether they look like pointers or + // not (some of them will). return ARG_SIZE(*sp) + 1; - } else if (LOOKS_LIKE_GHC_INFO(*stgCast(StgPtr*,sp))) { - return checkStackClosure(stgCast(StgClosure*,sp)); - } else { /* must be an untagged closure pointer in the stack */ - checkClosureShallow(*stgCast(StgClosure**,sp)); + } else if (LOOKS_LIKE_GHC_INFO(*(StgPtr *)sp)) { + return checkStackClosure((StgClosure *)sp); + } else { // must be an untagged closure pointer in the stack + checkClosureShallow(*(StgClosure **)sp); return 1; } } -/* check sections of stack between update frames */ +// check sections of stack between update frames void checkStackChunk( StgPtr sp, StgPtr stack_end ) { @@ -160,7 +204,7 @@ checkStackChunk( StgPtr sp, StgPtr stack_end ) while (p < stack_end) { p += checkStackObject( p ); } - ASSERT( p == stack_end ); + // ASSERT( p == stack_end ); -- HWL } StgOffset @@ -168,9 +212,7 @@ checkClosure( StgClosure* p ) { const StgInfoTable *info; -#ifndef INTERPRETER ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info)); -#endif /* Is it a static closure (i.e. in the data segment)? */ if (LOOKS_LIKE_STATIC(p)) { @@ -182,15 +224,6 @@ checkClosure( StgClosure* p ) info = get_itbl(p); switch (info->type) { - case BCO: - { - StgBCO* bco = stgCast(StgBCO*,p); - nat i; - for(i=0; i < bco->n_ptrs; ++i) { - ASSERT(LOOKS_LIKE_PTR(bcoConstPtr(bco,i))); - } - return bco_sizeW(bco); - } case MVAR: { @@ -198,6 +231,13 @@ checkClosure( StgClosure* p ) ASSERT(LOOKS_LIKE_PTR(mvar->head)); ASSERT(LOOKS_LIKE_PTR(mvar->tail)); ASSERT(LOOKS_LIKE_PTR(mvar->value)); +#if 0 +#if defined(PAR) + checkBQ((StgBlockingQueueElement *)mvar->head, p); +#else + checkBQ(mvar->head, p); +#endif +#endif return sizeofW(StgMVar); } @@ -210,11 +250,14 @@ checkClosure( StgClosure* p ) { nat i; for (i = 0; i < info->layout.payload.ptrs; i++) { - ASSERT(LOOKS_LIKE_PTR(payloadPtr(p,i))); + ASSERT(LOOKS_LIKE_PTR(p->payload[i])); } return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE); } + case BLACKHOLE_BQ: + checkBQ(((StgBlockingQueue *)p)->blocking_queue, p); + /* fall through to basic ptr check */ case FUN: case FUN_1_0: case FUN_0_1: @@ -230,33 +273,35 @@ checkClosure( StgClosure* p ) case IND_PERM: case IND_OLDGEN: case IND_OLDGEN_PERM: - case CAF_UNENTERED: - case CAF_ENTERED: - case CAF_BLACKHOLE: #ifdef TICKY_TICKY - case SE_CAF_BLACKHOLE: case SE_BLACKHOLE: + case SE_CAF_BLACKHOLE: #endif case BLACKHOLE: - case BLACKHOLE_BQ: + case CAF_BLACKHOLE: case FOREIGN: + case BCO: case STABLE_NAME: case MUT_VAR: + case MUT_CONS: case CONSTR_INTLIKE: case CONSTR_CHARLIKE: case CONSTR_STATIC: case CONSTR_NOCAF_STATIC: case THUNK_STATIC: case FUN_STATIC: - case IND_STATIC: { nat i; for (i = 0; i < info->layout.payload.ptrs; i++) { - ASSERT(LOOKS_LIKE_PTR(payloadPtr(p,i))); + ASSERT(LOOKS_LIKE_PTR(p->payload[i])); } return sizeW_fromITBL(info); } + case IND_STATIC: /* (1, 0) closure */ + ASSERT(LOOKS_LIKE_PTR(((StgIndStatic*)p)->indirectee)); + return sizeW_fromITBL(info); + case WEAK: /* deal with these specially - the info table isn't * representative of the actual layout. @@ -272,7 +317,7 @@ checkClosure( StgClosure* p ) } case THUNK_SELECTOR: - ASSERT(LOOKS_LIKE_PTR(stgCast(StgSelector*,p)->selectee)); + ASSERT(LOOKS_LIKE_PTR(((StgSelector *)p)->selectee)); return sizeofW(StgHeader) + MIN_UPD_SIZE; case IND: @@ -281,7 +326,7 @@ checkClosure( StgClosure* p ) * but they might appear during execution */ P_ q; - StgInd *ind = stgCast(StgInd*,p); + StgInd *ind = (StgInd *)p; ASSERT(LOOKS_LIKE_PTR(ind->indirectee)); q = (P_)p + sizeofW(StgInd); while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/ @@ -303,7 +348,7 @@ checkClosure( StgClosure* p ) case AP_UPD: /* we can treat this as being the same as a PAP */ case PAP: { - StgPAP *pap = stgCast(StgPAP*,p); + StgPAP *pap = (StgPAP *)p; ASSERT(LOOKS_LIKE_PTR(pap->fun)); checkStackChunk((StgPtr)pap->payload, (StgPtr)pap->payload + pap->n_args @@ -312,12 +357,12 @@ checkClosure( StgClosure* p ) } case ARR_WORDS: - return arr_words_sizeW(stgCast(StgArrWords*,p)); + return arr_words_sizeW((StgArrWords *)p); case MUT_ARR_PTRS: case MUT_ARR_PTRS_FROZEN: { - StgMutArrPtrs* a = stgCast(StgMutArrPtrs*,p); + StgMutArrPtrs* a = (StgMutArrPtrs *)p; nat i; for (i = 0; i < a->ptrs; i++) { ASSERT(LOOKS_LIKE_PTR(a->payload[i])); @@ -329,16 +374,85 @@ checkClosure( StgClosure* p ) checkTSO((StgTSO *)p); return tso_sizeW((StgTSO *)p); +#if defined(PAR) + case BLOCKED_FETCH: + ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga))); + ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node))); + return sizeofW(StgBlockedFetch); // see size used in evacuate() + +#ifdef DIST + case REMOTE_REF: + return sizeofW(StgFetchMe); +#endif //DIST + case FETCH_ME: + ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga)); + return sizeofW(StgFetchMe); // see size used in evacuate() + + case FETCH_ME_BQ: + checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p); + return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate() + + case RBH: + /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */ + ASSERT(((StgRBH *)p)->blocking_queue!=NULL); + if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE) + checkBQ(((StgRBH *)p)->blocking_queue, p); + ASSERT(LOOKS_LIKE_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p)))); + return BLACKHOLE_sizeW(); // see size used in evacuate() + // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p))); + +#endif + case EVACUATED: - barf("checkClosure: unimplemented/strange closure type"); + barf("checkClosure: found EVACUATED closure %d", + info->type); default: - barf("checkClosure"); + barf("checkClosure (closure type %d)", info->type); } -#undef LOOKS_LIKE_PTR } +#if defined(PAR) + +#define PVM_PE_MASK 0xfffc0000 +#define MAX_PVM_PES MAX_PES +#define MAX_PVM_TIDS MAX_PES +#define MAX_SLOTS 100000 + +rtsBool +looks_like_tid(StgInt tid) +{ + StgInt hi = (tid & PVM_PE_MASK) >> 18; + StgInt lo = (tid & ~PVM_PE_MASK); + rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS); + return ok; +} + +rtsBool +looks_like_slot(StgInt slot) +{ + /* if tid is known better use looks_like_ga!! */ + rtsBool ok = slotpayload.gc.gtid); + rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ? + (ga)->payload.gc.slot<=highest_slot() : + (ga)->payload.gc.slotstart; - } else { - p = start; + for (; bd != NULL; bd = bd->link) { + p = bd->start; + while (p < bd->free) { + nat size = checkClosure((StgClosure *)p); + /* This is the smallest size of closure that can live in the heap */ + ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); + p += size; + + /* skip over slop */ + while (p < bd->free && + (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; } + } } +} - while (bd != NULL) { - while (p < bd->free) { - nat size = checkClosure(stgCast(StgClosure*,p)); - /* This is the smallest size of closure that can live in the heap. */ - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - p += size; - - /* skip over slop */ - while (p < bd->free && - (*p == 0 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; } - } - bd = bd->link; - if (bd != NULL) { - p = bd->start; - } +#if defined(PAR) +/* + Check heap between start and end. Used after unpacking graphs. +*/ +void +checkHeapChunk(StgPtr start, StgPtr end) +{ + extern globalAddr *LAGAlookup(StgClosure *addr); + StgPtr p; + nat size; + + for (p=start; ptype == FETCH_ME && + *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) { + /* if it's a FM created during unpack and commoned up, it's not global */ + ASSERT(LAGAlookup((StgClosure*)p)==NULL); + size = sizeofW(StgFetchMe); + } else if (get_itbl((StgClosure*)p)->type == IND) { + *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */ + size = MIN_UPD_SIZE; + } else { + size = checkClosure((StgClosure *)p); + /* This is the smallest size of closure that can live in the heap. */ + ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); } + } +} +#else /* !PAR */ +void +checkHeapChunk(StgPtr start, StgPtr end) +{ + StgPtr p; + nat size; + + for (p=start; p= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); + } } +#endif -extern void +void checkChain(bdescr *bd) { while (bd != NULL) { @@ -391,31 +540,32 @@ void checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su ) { /* check everything down to the first update frame */ - checkStackChunk( sp, stgCast(StgPtr,su) ); - while ( stgCast(StgPtr,su) < stack_end) { - sp = stgCast(StgPtr,su); + checkStackChunk( sp, (StgPtr)su ); + while ( (StgPtr)su < stack_end) { + sp = (StgPtr)su; switch (get_itbl(su)->type) { case UPDATE_FRAME: su = su->link; break; case SEQ_FRAME: - su = stgCast(StgSeqFrame*,su)->link; + su = ((StgSeqFrame *)su)->link; break; case CATCH_FRAME: - su = stgCast(StgCatchFrame*,su)->link; + su = ((StgCatchFrame *)su)->link; break; case STOP_FRAME: - /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */ + /* not quite: ASSERT((StgPtr)su == stack_end); */ return; default: barf("checkStack: weird record found on update frame list."); } - checkStackChunk( sp, stgCast(StgPtr,su) ); + checkStackChunk( sp, (StgPtr)su ); } - ASSERT(stgCast(StgPtr,su) == stack_end); + ASSERT((StgPtr)su == stack_end); } -extern void + +void checkTSO(StgTSO *tso) { StgPtr sp = tso->sp; @@ -424,7 +574,12 @@ checkTSO(StgTSO *tso) StgOffset stack_size = tso->stack_size; StgPtr stack_end = stack + stack_size; - if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) { + if (tso->what_next == ThreadRelocated) { + checkTSO(tso->link); + return; + } + + if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) { /* The garbage collector doesn't bother following any pointers * from dead threads, so don't check sanity here. */ @@ -432,11 +587,173 @@ checkTSO(StgTSO *tso) } ASSERT(stack <= sp && sp < stack_end); - ASSERT(sp <= stgCast(StgPtr,su)); + ASSERT(sp <= (StgPtr)su); + +#if defined(PAR) + ASSERT(tso->par.magic==TSO_MAGIC); + + switch (tso->why_blocked) { + case BlockedOnGA: + checkClosureShallow(tso->block_info.closure); + ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */ + get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ); + break; + case BlockedOnGA_NoSend: + checkClosureShallow(tso->block_info.closure); + ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ); + break; + case BlockedOnBlackHole: + checkClosureShallow(tso->block_info.closure); + ASSERT(/* Can't be a BLACKHOLE because *this* closure is on its BQ */ + get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ || + get_itbl(tso->block_info.closure)->type==RBH); + break; + case BlockedOnRead: + case BlockedOnWrite: + case BlockedOnDelay: + /* isOnBQ(blocked_queue) */ + break; + case BlockedOnException: + /* isOnSomeBQ(tso) */ + ASSERT(get_itbl(tso->block_info.tso)->type==TSO); + break; + case BlockedOnMVar: + ASSERT(get_itbl(tso->block_info.closure)->type==MVAR); + break; + default: + /* + Could check other values of why_blocked but I am more + lazy than paranoid (bad combination) -- HWL + */ + } + + /* if the link field is non-nil it most point to one of these + three closure types */ + ASSERT(tso->link == END_TSO_QUEUE || + get_itbl(tso->link)->type == TSO || + get_itbl(tso->link)->type == BLOCKED_FETCH || + get_itbl(tso->link)->type == CONSTR); +#endif checkStack(sp, stack_end, su); } +#if defined(GRAN) +void +checkTSOsSanity(void) { + nat i, tsos; + StgTSO *tso; + + belch("Checking sanity of all runnable TSOs:"); + + for (i=0, tsos=0; ilink) { + fprintf(stderr, "TSO %p on PE %d ...", tso, i); + checkTSO(tso); + fprintf(stderr, "OK, "); + tsos++; + } + } + + belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc); +} + + +// still GRAN only + +rtsBool +checkThreadQSanity (PEs proc, rtsBool check_TSO_too) +{ + StgTSO *tso, *prev; + + /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */ + ASSERT(run_queue_hds[proc]!=NULL); + ASSERT(run_queue_tls[proc]!=NULL); + /* if either head or tail is NIL then the other one must be NIL, too */ + ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE); + ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE); + for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE; + tso!=END_TSO_QUEUE; + prev=tso, tso=tso->link) { + ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) && + (prev==END_TSO_QUEUE || prev->link==tso)); + if (check_TSO_too) + checkTSO(tso); + } + ASSERT(prev==run_queue_tls[proc]); +} + +rtsBool +checkThreadQsSanity (rtsBool check_TSO_too) +{ + PEs p; + + for (p=0; pglobal_link) { + ASSERT(LOOKS_LIKE_PTR(tso)); + ASSERT(get_itbl(tso)->type == TSO); + if (checkTSOs) + checkTSO(tso); + } +} + +/* ----------------------------------------------------------------------------- + Check mutable list sanity. + -------------------------------------------------------------------------- */ + +void +checkMutableList( StgMutClosure *p, nat gen ) +{ + bdescr *bd; + + for (; p != END_MUT_LIST; p = p->mut_link) { + bd = Bdescr((P_)p); + ASSERT(closure_MUTABLE(p)); + ASSERT(bd->gen_no == gen); + ASSERT(LOOKS_LIKE_PTR(p->mut_link)); + } +} + +void +checkMutOnceList( StgMutClosure *p, nat gen ) +{ + bdescr *bd; + StgInfoTable *info; + + for (; p != END_MUT_LIST; p = p->mut_link) { + bd = Bdescr((P_)p); + info = get_itbl(p); + + ASSERT(!closure_MUTABLE(p)); + ASSERT(ip_STATIC(info) || bd->gen_no == gen); + ASSERT(LOOKS_LIKE_PTR(p->mut_link)); + + switch (info->type) { + case IND_STATIC: + case IND_OLDGEN: + case IND_OLDGEN_PERM: + case MUT_CONS: + break; + default: + barf("checkMutOnceList: strange closure %p (%s)", + p, info_type((StgClosure *)p)); + } + } +} + /* ----------------------------------------------------------------------------- Check Blackhole Sanity @@ -448,7 +765,8 @@ checkTSO(StgTSO *tso) the update frame list. -------------------------------------------------------------------------- */ -rtsBool isBlackhole( StgTSO* tso, StgClosure* p ) +rtsBool +isBlackhole( StgTSO* tso, StgClosure* p ) { StgUpdateFrame* su = tso->su; do { @@ -461,10 +779,10 @@ rtsBool isBlackhole( StgTSO* tso, StgClosure* p ) } break; case SEQ_FRAME: - su = stgCast(StgSeqFrame*,su)->link; + su = ((StgSeqFrame *)su)->link; break; case CATCH_FRAME: - su = stgCast(StgCatchFrame*,su)->link; + su = ((StgCatchFrame *)su)->link; break; case STOP_FRAME: return rtsFalse; @@ -474,4 +792,184 @@ rtsBool isBlackhole( StgTSO* tso, StgClosure* p ) } while (1); } +/* + Check the static objects list. +*/ +void +checkStaticObjects ( StgClosure* static_objects ) +{ + StgClosure *p = static_objects; + StgInfoTable *info; + + while (p != END_OF_STATIC_LIST) { + checkClosure(p); + info = get_itbl(p); + switch (info->type) { + case IND_STATIC: + { + StgClosure *indirectee = ((StgIndStatic *)p)->indirectee; + + ASSERT(LOOKS_LIKE_PTR(indirectee)); + ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info)); + p = IND_STATIC_LINK((StgClosure *)p); + break; + } + + case THUNK_STATIC: + p = THUNK_STATIC_LINK((StgClosure *)p); + break; + + case FUN_STATIC: + p = FUN_STATIC_LINK((StgClosure *)p); + break; + + case CONSTR_STATIC: + p = STATIC_LINK(info,(StgClosure *)p); + break; + + default: + barf("checkStaticObjetcs: strange closure %p (%s)", + p, info_type(p)); + } + } +} + +/* + Check the sanity of a blocking queue starting at bqe with closure being + the closure holding the blocking queue. + Note that in GUM we can have several different closure types in a + blocking queue +*/ +#if defined(PAR) +void +checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure) +{ + rtsBool end = rtsFalse; + StgInfoTable *info = get_itbl(closure); + + ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR + || info->type == FETCH_ME_BQ || info->type == RBH); + + do { + switch (get_itbl(bqe)->type) { + case BLOCKED_FETCH: + case TSO: + checkClosure((StgClosure *)bqe); + bqe = bqe->link; + end = (bqe==END_BQ_QUEUE); + break; + + case CONSTR: + checkClosure((StgClosure *)bqe); + end = rtsTrue; + break; + + default: + barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n", + get_itbl(bqe)->type, closure, info_type(closure)); + } + } while (!end); +} +#elif defined(GRAN) +void +checkBQ (StgTSO *bqe, StgClosure *closure) +{ + rtsBool end = rtsFalse; + StgInfoTable *info = get_itbl(closure); + + ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR); + + do { + switch (get_itbl(bqe)->type) { + case BLOCKED_FETCH: + case TSO: + checkClosure((StgClosure *)bqe); + bqe = bqe->link; + end = (bqe==END_BQ_QUEUE); + break; + + default: + barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n", + get_itbl(bqe)->type, closure, info_type(closure)); + } + } while (!end); +} +#else +void +checkBQ (StgTSO *bqe, StgClosure *closure) +{ + rtsBool end = rtsFalse; + StgInfoTable *info = get_itbl(closure); + + ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR); + + do { + switch (get_itbl(bqe)->type) { + case TSO: + checkClosure((StgClosure *)bqe); + bqe = bqe->link; + end = (bqe==END_TSO_QUEUE); + break; + + default: + barf("checkBQ: strange closure %d in blocking queue for closure %p\n", + get_itbl(bqe)->type, closure, info->type); + } + } while (!end); +} + +#endif + + + +/* + This routine checks the sanity of the LAGA and GALA tables. They are + implemented as lists through one hash table, LAtoGALAtable, because entries + in both tables have the same structure: + - the LAGA table maps local addresses to global addresses; it starts + with liveIndirections + - the GALA table maps global addresses to local addresses; it starts + with liveRemoteGAs +*/ + +#if defined(PAR) +#include "Hash.h" + +/* hidden in parallel/Global.c; only accessed for testing here */ +extern GALA *liveIndirections; +extern GALA *liveRemoteGAs; +extern HashTable *LAtoGALAtable; + +void +checkLAGAtable(rtsBool check_closures) +{ + GALA *gala, *gala0; + nat n=0, m=0; // debugging + + for (gala = liveIndirections; gala != NULL; gala = gala->next) { + n++; + gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la); + ASSERT(!gala->preferred || gala == gala0); + ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info)); + ASSERT(gala->next!=gala); // detect direct loops + if ( check_closures ) { + checkClosure((StgClosure *)gala->la); + } + } + + for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) { + m++; + gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la); + ASSERT(!gala->preferred || gala == gala0); + ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info)); + ASSERT(gala->next!=gala); // detect direct loops + /* + if ( check_closures ) { + checkClosure((StgClosure *)gala->la); + } + */ + } +} +#endif + #endif /* DEBUG */