X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FSanity.c;h=f6947c9f8c75368bb02300fdc939c44b2252cb9d;hb=da69fa9c5047c5b0d05bdb05eaddefa1eb5d5a36;hp=82d6add08a0ec51217e4502d3a43a03b4de79f3f;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c index 82d6add..f6947c9 100644 --- a/ghc/rts/Sanity.c +++ b/ghc/rts/Sanity.c @@ -130,6 +130,9 @@ checkStackFrame( StgPtr c ) case UPDATE_FRAME: ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgUpdateFrame*)c)->updatee)); + case ATOMICALLY_FRAME: + case CATCH_RETRY_FRAME: + case CATCH_STM_FRAME: case CATCH_FRAME: // small bitmap cases (<= 32 entries) case STOP_FRAME: @@ -151,8 +154,8 @@ checkStackFrame( StgPtr c ) case RET_BIG: // large bitmap (> 32 entries) case RET_VEC_BIG: - size = info->i.layout.large_bitmap->size; - checkLargeBitmap((StgPtr)c + 1, info->i.layout.large_bitmap, size); + size = GET_LARGE_BITMAP(&info->i)->size; + checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size); return 1 + size; case RET_FUN: @@ -166,11 +169,11 @@ checkStackFrame( StgPtr c ) switch (fun_info->f.fun_type) { case ARG_GEN: checkSmallBitmap((StgPtr)ret_fun->payload, - BITMAP_BITS(fun_info->f.bitmap), size); + BITMAP_BITS(fun_info->f.b.bitmap), size); break; case ARG_GEN_BIG: checkLargeBitmap((StgPtr)ret_fun->payload, - (StgLargeBitmap *)fun_info->f.bitmap, size); + GET_FUN_LARGE_BITMAP(fun_info), size); break; default: checkSmallBitmap((StgPtr)ret_fun->payload, @@ -182,7 +185,7 @@ checkStackFrame( StgPtr c ) } default: - barf("checkStackFrame: weird activation record found on stack (%p).",c); + barf("checkStackFrame: weird activation record found on stack (%p %d).",c,info->i.type); } } @@ -199,6 +202,40 @@ checkStackChunk( StgPtr sp, StgPtr stack_end ) // ASSERT( p == stack_end ); -- HWL } +static void +checkPAP (StgClosure *fun, StgClosure** payload, StgWord n_args) +{ + StgClosure *p; + StgFunInfoTable *fun_info; + + ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun)); + fun_info = get_fun_itbl(fun); + + p = (StgClosure *)payload; + switch (fun_info->f.fun_type) { + case ARG_GEN: + checkSmallBitmap( (StgPtr)payload, + BITMAP_BITS(fun_info->f.b.bitmap), n_args ); + break; + case ARG_GEN_BIG: + checkLargeBitmap( (StgPtr)payload, + GET_FUN_LARGE_BITMAP(fun_info), + n_args ); + break; + case ARG_BCO: + checkLargeBitmap( (StgPtr)payload, + BCO_BITMAP(fun), + n_args ); + break; + default: + checkSmallBitmap( (StgPtr)payload, + BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]), + n_args ); + break; + } +} + + StgOffset checkClosure( StgClosure* p ) { @@ -241,14 +278,11 @@ checkClosure( StgClosure* p ) { nat i; for (i = 0; i < info->layout.payload.ptrs; i++) { - ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i])); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i])); } - return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE); + return stg_max(thunk_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: @@ -270,10 +304,8 @@ checkClosure( StgClosure* p ) #endif case BLACKHOLE: case CAF_BLACKHOLE: - case FOREIGN: case STABLE_NAME: case MUT_VAR: - case MUT_CONS: case CONSTR_INTLIKE: case CONSTR_CHARLIKE: case CONSTR_STATIC: @@ -317,19 +349,16 @@ checkClosure( StgClosure* p ) case THUNK_SELECTOR: ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgSelector *)p)->selectee)); - return sizeofW(StgHeader) + MIN_UPD_SIZE; + return THUNK_SELECTOR_sizeW(); case IND: { /* we don't expect to see any of these after GC * but they might appear during execution */ - P_ q; StgInd *ind = (StgInd *)p; ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee)); - q = (P_)p + sizeofW(StgInd); - while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/ - return q - (P_)p; + return sizeofW(StgHeader) + MIN_UPD_SIZE; } case RET_BCO: @@ -341,41 +370,24 @@ checkClosure( StgClosure* p ) case UPDATE_FRAME: case STOP_FRAME: case CATCH_FRAME: + case ATOMICALLY_FRAME: + case CATCH_RETRY_FRAME: + case CATCH_STM_FRAME: barf("checkClosure: stack frame"); - case AP: /* we can treat this as being the same as a PAP */ + case AP: + { + StgAP* ap = (StgAP *)p; + checkPAP (ap->fun, ap->payload, ap->n_args); + return ap_sizeW(ap); + } + case PAP: - { - StgFunInfoTable *fun_info; - StgPAP* pap = (StgPAP *)p; - - ASSERT(LOOKS_LIKE_CLOSURE_PTR(pap->fun)); - fun_info = get_fun_itbl(pap->fun); - - p = (StgClosure *)pap->payload; - switch (fun_info->f.fun_type) { - case ARG_GEN: - checkSmallBitmap( (StgPtr)pap->payload, - BITMAP_BITS(fun_info->f.bitmap), pap->n_args ); - break; - case ARG_GEN_BIG: - checkLargeBitmap( (StgPtr)pap->payload, - (StgLargeBitmap *)fun_info->f.bitmap, - pap->n_args ); - break; - case ARG_BCO: - checkLargeBitmap( (StgPtr)pap->payload, - BCO_BITMAP(pap->fun), - pap->n_args ); - break; - default: - checkSmallBitmap( (StgPtr)pap->payload, - BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]), - pap->n_args ); - break; - } - return pap_sizeW(pap); - } + { + StgPAP* pap = (StgPAP *)p; + checkPAP (pap->fun, pap->payload, pap->n_args); + return pap_sizeW(pap); + } case AP_STACK: { @@ -388,8 +400,10 @@ checkClosure( StgClosure* p ) case ARR_WORDS: return arr_words_sizeW((StgArrWords *)p); - case MUT_ARR_PTRS: + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: { StgMutArrPtrs* a = (StgMutArrPtrs *)p; nat i; @@ -413,7 +427,7 @@ checkClosure( StgClosure* p ) #ifdef DIST case REMOTE_REF: return sizeofW(StgFetchMe); -#endif //DIST +#endif /*DIST */ case FETCH_ME: ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga)); @@ -433,6 +447,44 @@ checkClosure( StgClosure* p ) // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p))); #endif + + case TVAR_WAIT_QUEUE: + { + StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->next_queue_entry)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(wq->prev_queue_entry)); + return sizeofW(StgTVarWaitQueue); + } + + case TVAR: + { + StgTVar *tv = (StgTVar *)p; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->current_value)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tv->first_wait_queue_entry)); + return sizeofW(StgTVar); + } + + case TREC_CHUNK: + { + nat i; + StgTRecChunk *tc = (StgTRecChunk *)p; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->prev_chunk)); + for (i = 0; i < tc -> next_entry_idx; i ++) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].tvar)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].expected_value)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].new_value)); + } + return sizeofW(StgTRecChunk); + } + + case TREC_HEADER: + { + StgTRecHeader *trec = (StgTRecHeader *)p; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> enclosing_trec)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(trec -> current_chunk)); + return sizeofW(StgTRecHeader); + } + case EVACUATED: barf("checkClosure: found EVACUATED closure %d", @@ -496,6 +548,12 @@ checkHeap(bdescr *bd) { StgPtr p; +#if defined(SMP) + // heap sanity checking doesn't work with SMP, because we can't + // zero the slop (see Updates.h). + return; +#endif + for (; bd != NULL; bd = bd->link) { p = bd->start; while (p < bd->free) { @@ -601,14 +659,13 @@ checkTSO(StgTSO *tso) 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 || + 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_TARGET_OS) +#if defined(mingw32_HOST_OS) case BlockedOnDoProc: #endif /* isOnBQ(blocked_queue) */ @@ -620,6 +677,9 @@ checkTSO(StgTSO *tso) 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 @@ -644,18 +704,18 @@ checkTSOsSanity(void) { nat i, tsos; StgTSO *tso; - belch("Checking sanity of all runnable TSOs:"); + debugBelch("Checking sanity of all runnable TSOs:"); for (i=0, tsos=0; ilink) { - fprintf(stderr, "TSO %p on PE %d ...", tso, i); + debugBelch("TSO %p on PE %d ...", tso, i); checkTSO(tso); - fprintf(stderr, "OK, "); + debugBelch("OK, "); tsos++; } } - belch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc); + debugBelch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc); } @@ -715,41 +775,16 @@ checkGlobalTSOList (rtsBool checkTSOs) -------------------------------------------------------------------------- */ void -checkMutableList( StgMutClosure *p, nat gen ) +checkMutableList( bdescr *mut_bd, nat gen ) { bdescr *bd; + StgPtr q; + StgClosure *p; - 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_CLOSURE_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_CLOSURE_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)); + for (bd = mut_bd; bd != NULL; bd = bd->link) { + for (q = bd->start; q < bd->free; q++) { + p = (StgClosure *)*q; + ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen); } } } @@ -773,20 +808,20 @@ checkStaticObjects ( StgClosure* static_objects ) ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee)); ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info)); - p = IND_STATIC_LINK((StgClosure *)p); + p = *IND_STATIC_LINK((StgClosure *)p); break; } case THUNK_STATIC: - p = THUNK_STATIC_LINK((StgClosure *)p); + p = *THUNK_STATIC_LINK((StgClosure *)p); break; case FUN_STATIC: - p = FUN_STATIC_LINK((StgClosure *)p); + p = *FUN_STATIC_LINK((StgClosure *)p); break; case CONSTR_STATIC: - p = STATIC_LINK(info,(StgClosure *)p); + p = *STATIC_LINK(info,(StgClosure *)p); break; default: @@ -809,8 +844,7 @@ 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); + ASSERT(info->type == MVAR || info->type == FETCH_ME_BQ || info->type == RBH); do { switch (get_itbl(bqe)->type) { @@ -839,7 +873,7 @@ checkBQ (StgTSO *bqe, StgClosure *closure) rtsBool end = rtsFalse; StgInfoTable *info = get_itbl(closure); - ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR); + ASSERT(info->type == MVAR); do { switch (get_itbl(bqe)->type) { @@ -856,30 +890,6 @@ checkBQ (StgTSO *bqe, StgClosure *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