#ifdef DEBUG /* whole file */
-#include "RtsFlags.h"
#include "RtsUtils.h"
-#include "BlockAlloc.h"
+#include "sm/Storage.h"
+#include "sm/BlockAlloc.h"
#include "Sanity.h"
-#include "MBlock.h"
-#include "Storage.h"
#include "Schedule.h"
#include "Apply.h"
+#include "Printer.h"
/* -----------------------------------------------------------------------------
Forward decls.
static void
checkClosureShallow( StgClosure* p )
{
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+ StgClosure *q;
+
+ q = UNTAG_CLOSURE(p);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
/* Is it a static closure? */
- if (!HEAP_ALLOCED(p)) {
- ASSERT(closure_STATIC(p));
+ if (!HEAP_ALLOCED(q)) {
+ ASSERT(closure_STATIC(q));
} else {
- ASSERT(!closure_STATIC(p));
+ ASSERT(!closure_STATIC(q));
}
}
// small bitmap cases (<= 32 entries)
case STOP_FRAME:
case RET_SMALL:
- case RET_VEC_SMALL:
size = BITMAP_SIZE(info->i.layout.bitmap);
checkSmallBitmap((StgPtr)c + 1,
BITMAP_BITS(info->i.layout.bitmap), size);
}
case RET_BIG: // large bitmap (> 32 entries)
- case RET_VEC_BIG:
size = GET_LARGE_BITMAP(&info->i)->size;
checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size);
return 1 + size;
StgRetFun *ret_fun;
ret_fun = (StgRetFun *)c;
- fun_info = get_fun_itbl(ret_fun->fun);
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
size = ret_fun->size;
switch (fun_info->f.fun_type) {
case ARG_GEN:
}
static void
-checkPAP (StgClosure *fun, StgClosure** payload, StgWord n_args)
+checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args)
{
+ StgClosure *fun;
StgClosure *p;
StgFunInfoTable *fun_info;
+ fun = UNTAG_CLOSURE(tagged_fun);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun));
fun_info = get_fun_itbl(fun);
n_args );
break;
}
+
+ ASSERT(fun_info->f.arity > TAG_MASK ? GET_CLOSURE_TAG(tagged_fun) == 1
+ : GET_CLOSURE_TAG(tagged_fun) == fun_info->f.arity);
}
{
const StgInfoTable *info;
- ASSERT(LOOKS_LIKE_INFO_PTR(p->header.info));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+ p = UNTAG_CLOSURE(p);
/* Is it a static closure (i.e. in the data segment)? */
if (!HEAP_ALLOCED(p)) {
ASSERT(closure_STATIC(p));
ASSERT(!closure_STATIC(p));
}
- info = get_itbl(p);
+ info = p->header.info;
+
+ if (IS_FORWARDING_PTR(info)) {
+ barf("checkClosure: found EVACUATED closure %d", info->type);
+ }
+ info = INFO_PTR_TO_STRUCT(info);
+
switch (info->type) {
- case MVAR:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
{
StgMVar *mvar = (StgMVar *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value));
-#if 0
-#if defined(PAR)
- checkBQ((StgBlockingQueueElement *)mvar->head, p);
-#else
- checkBQ(mvar->head, p);
-#endif
-#endif
return sizeofW(StgMVar);
}
case IND_PERM:
case IND_OLDGEN:
case IND_OLDGEN_PERM:
-#ifdef TICKY_TICKY
- case SE_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
-#endif
case BLACKHOLE:
case CAF_BLACKHOLE:
case STABLE_NAME:
ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->instrs));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->literals));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->ptrs));
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->itbls));
return bco_sizeW(bco);
}
case RET_BCO:
case RET_SMALL:
- case RET_VEC_SMALL:
case RET_BIG:
- case RET_VEC_BIG:
case RET_DYN:
case UPDATE_FRAME:
case STOP_FRAME:
checkTSO((StgTSO *)p);
return tso_sizeW((StgTSO *)p);
-#if defined(PAR)
-
- case BLOCKED_FETCH:
- ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
- ASSERT(LOOKS_LIKE_CLOSURE_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_INFO_PTR(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
- return BLACKHOLE_sizeW(); // see size used in evacuate()
- // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
-
-#endif
-
- case TVAR_WAIT_QUEUE:
+ case TVAR_WATCH_QUEUE:
{
- StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
+ StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->next_queue_entry));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->prev_queue_entry));
- return sizeofW(StgTVarWaitQueue);
+ return sizeofW(StgTVarWatchQueue);
+ }
+
+ case INVARIANT_CHECK_QUEUE:
+ {
+ StgInvariantCheckQueue *q = (StgInvariantCheckQueue *)p;
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(q->invariant));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(q->my_execution));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(q->next_queue_entry));
+ return sizeofW(StgInvariantCheckQueue);
+ }
+
+ case ATOMIC_INVARIANT:
+ {
+ StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(invariant->code));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(invariant->last_execution));
+ return sizeofW(StgAtomicInvariant);
}
case TVAR:
{
StgTVar *tv = (StgTVar *)p;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->current_value));
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->first_wait_queue_entry));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->first_watch_queue_entry));
return sizeofW(StgTVar);
}
return sizeofW(StgTRecHeader);
}
-
- case EVACUATED:
- barf("checkClosure: found EVACUATED closure %d",
- info->type);
default:
barf("checkClosure (closure type %d)", info->type);
}
}
-#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 = slot<MAX_SLOTS;
- // This refers only to the no. of slots on the current PE
- // rtsBool ok = slot<=highest_slot();
- return ok;
-}
-
-rtsBool
-looks_like_ga(globalAddr *ga)
-{
- rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
- rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
- (ga)->payload.gc.slot<=highest_slot() :
- (ga)->payload.gc.slot<MAX_SLOTS;
- rtsBool ok = is_tid && is_slot;
- return ok;
-}
-
-#endif
-
/* -----------------------------------------------------------------------------
Check Heap Sanity
/* skip over slop */
while (p < bd->free &&
- (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR((void*)*p))) { p++; }
+ (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR(*p))) { p++; }
}
}
}
-#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; p<end; p+=size) {
- ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
- if (get_itbl((StgClosure*)p)->type == 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 = sizeofW(StgInd);
- } else {
- size = checkClosure((StgClosure *)p);
- /* This is the smallest size of closure that can live in the heap. */
- ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
- }
- }
-}
-#else /* !PAR */
-void
-checkHeapChunk(StgPtr start, StgPtr end)
-{
- StgPtr p;
- nat size;
-
- for (p=start; p<end; p+=size) {
- ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
+ ASSERT(LOOKS_LIKE_INFO_PTR(*p));
size = checkClosure((StgClosure *)p);
/* This is the smallest size of closure that can live in the heap. */
ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
}
}
-#endif
void
-checkChain(bdescr *bd)
+checkLargeObjects(bdescr *bd)
{
while (bd != NULL) {
- checkClosure((StgClosure *)bd->start);
+ if (!(bd->flags & BF_PINNED)) {
+ checkClosure((StgClosure *)bd->start);
+ }
bd = bd->link;
}
}
StgPtr stack_end = stack + stack_size;
if (tso->what_next == ThreadRelocated) {
- checkTSO(tso->link);
+ checkTSO(tso->_link);
return;
}
ASSERT(stack <= sp && sp < stack_end);
-#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(get_itbl(tso->block_info.closure)->type==BLACKHOLE ||
- get_itbl(tso->block_info.closure)->type==RBH);
- break;
- case BlockedOnRead:
- case BlockedOnWrite:
- case BlockedOnDelay:
-#if defined(mingw32_HOST_OS)
- case BlockedOnDoProc:
-#endif
- /* 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;
- case BlockedOnSTM:
- ASSERT(tso->block_info.closure == END_TSO_QUEUE);
- 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
-
checkStackChunk(sp, stack_end);
}
-#if defined(GRAN)
-void
-checkTSOsSanity(void) {
- nat i, tsos;
- StgTSO *tso;
-
- debugBelch("Checking sanity of all runnable TSOs:");
-
- for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
- for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
- debugBelch("TSO %p on PE %d ...", tso, i);
- checkTSO(tso);
- debugBelch("OK, ");
- tsos++;
- }
- }
-
- debugBelch(" 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; p<RtsFlags.GranFlags.proc; p++)
- checkThreadQSanity(p, check_TSO_too);
-}
-#endif /* GRAN */
-
/*
Check that all TSOs have been evacuated.
Optionally also check the sanity of the TSOs.
void
checkGlobalTSOList (rtsBool checkTSOs)
{
- extern StgTSO *all_threads;
StgTSO *tso;
- for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
- ASSERT(get_itbl(tso)->type == TSO);
- if (checkTSOs)
- checkTSO(tso);
+ nat s;
+
+ for (s = 0; s < total_steps; s++) {
+ for (tso=all_steps[s].threads; tso != END_TSO_QUEUE;
+ tso = tso->global_link) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
+ ASSERT(get_itbl(tso)->type == TSO);
+ if (checkTSOs)
+ checkTSO(tso);
+
+ // If this TSO is dirty and in an old generation, it better
+ // be on the mutable list.
+ if (tso->what_next == ThreadRelocated) continue;
+ if (tso->flags & (TSO_DIRTY|TSO_LINK_DIRTY)) {
+ ASSERT(Bdescr((P_)tso)->gen_no == 0 || (tso->flags & TSO_MARKED));
+ tso->flags &= ~TSO_MARKED;
+ }
+ }
}
}
for (q = bd->start; q < bd->free; q++) {
p = (StgClosure *)*q;
ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
+ if (get_itbl(p)->type == TSO) {
+ ((StgTSO *)p)->flags |= TSO_MARKED;
+ }
}
}
}
+void
+checkMutableLists (rtsBool checkTSOs)
+{
+ nat g, i;
+
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ checkMutableList(generations[g].mut_list, g);
+ for (i = 0; i < n_capabilities; i++) {
+ checkMutableList(capabilities[i].mut_lists[g], g);
+ }
+ }
+ checkGlobalTSOList(checkTSOs);
+}
+
/*
Check the static objects list.
*/
switch (info->type) {
case IND_STATIC:
{
- StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
+ StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
- ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
+ ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
p = *IND_STATIC_LINK((StgClosure *)p);
break;
}
}
}
-/*
- 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 == 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 == 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);
-}
-#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_INFO_PTR(((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_INFO_PTR(((StgClosure *)gala->la)->header.info));
- ASSERT(gala->next!=gala); // detect direct loops
- /*
- if ( check_closures ) {
- checkClosure((StgClosure *)gala->la);
- }
- */
- }
-}
-#endif
-
#endif /* DEBUG */
projects / ghc-hetmet.git / blobdiff