#define INLINE inline
#endif
+#include "PosixSource.h"
#include "Rts.h"
+
#include "RtsUtils.h"
#include "RetainerProfile.h"
#include "RetainerSet.h"
-#include "Storage.h"
#include "Schedule.h"
-#include "Stable.h"
#include "Printer.h"
-#include "RtsFlags.h"
#include "Weak.h"
-#include "Sanity.h"
+#include "sm/Sanity.h"
#include "Profiling.h"
#include "Stats.h"
#include "ProfHeap.h"
#include "Apply.h"
+#include "sm/Storage.h" // for END_OF_STATIC_LIST
/*
Note: what to change in order to plug-in a new retainer profiling scheme?
bitmap = info->next.srt.srt_bitmap;
while (bitmap != 0) {
if ((bitmap & 1) != 0) {
-#ifdef ENABLE_WIN32_DLL_SUPPORT
-
+#if defined(__PIC__) && defined(mingw32_HOST_OS)
if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
else
// no child, no SRT
case CONSTR_0_1:
case CONSTR_0_2:
- case CAF_BLACKHOLE:
- case BLACKHOLE:
- case SE_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
case ARR_WORDS:
*first_child = NULL;
return;
*first_child = ((StgSelector *)c)->selectee;
return;
case IND_PERM:
- case IND_OLDGEN_PERM:
- case IND_OLDGEN:
+ case BLACKHOLE:
*first_child = ((StgInd *)c)->indirectee;
return;
case CONSTR_1_0:
// three children (fixed), no SRT
// need to push a stackElement
- case MVAR:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
// head must be TSO and the head of a linked list of TSOs.
// Shoule it be a child? Seems to be yes.
*first_child = (StgClosure *)((StgMVar *)c)->head;
// layout.payload.ptrs, no SRT
case CONSTR:
- case STABLE_NAME:
+ case PRIM:
+ case MUT_PRIM:
case BCO:
case CONSTR_STATIC:
init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
return; // no child
break;
- case TVAR_WATCH_QUEUE:
- *first_child = (StgClosure *)((StgTVarWatchQueue *)c)->closure;
- se.info.next.step = 2; // 2 = second
- break;
- case TVAR:
- *first_child = (StgClosure *)((StgTVar *)c)->current_value;
- break;
- case TREC_HEADER:
- *first_child = (StgClosure *)((StgTRecHeader *)c)->enclosing_trec;
- break;
case TREC_CHUNK:
*first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
se.info.next.step = 0; // entry no.
case AP:
case AP_STACK:
case TSO:
+ case STACK:
case IND_STATIC:
case CONSTR_NOCAF_STATIC:
// stack objects
case UPDATE_FRAME:
case CATCH_FRAME:
+ case UNDERFLOW_FRAME:
case STOP_FRAME:
case RET_DYN:
case RET_BCO:
case RET_SMALL:
- case RET_VEC_SMALL:
case RET_BIG:
- case RET_VEC_BIG:
// invalid objects
case IND:
- case BLOCKED_FETCH:
- case FETCH_ME:
- case FETCH_ME_BQ:
- case RBH:
- case REMOTE_REF:
- case EVACUATED:
case INVALID_OBJECT:
default:
barf("Invalid object *c in push()");
// three children (fixed), no SRT
// need to push a stackElement
- case MVAR:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
if (se->info.next.step == 2) {
*c = (StgClosure *)((StgMVar *)se->c)->tail;
se->info.next.step++; // move to the next step
*r = se->c_child_r;
return;
- case TVAR_WATCH_QUEUE:
- if (se->info.next.step == 2) {
- *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->next_queue_entry;
- se->info.next.step++; // move to the next step
- // no popOff
- } else {
- *c = (StgClosure *)((StgTVarWatchQueue *)se->c)->prev_queue_entry;
- popOff();
- }
- *cp = se->c;
- *r = se->c_child_r;
- return;
-
- case TVAR:
- *c = (StgClosure *)((StgTVar *)se->c)->first_watch_queue_entry;
- *cp = se->c;
- *r = se->c_child_r;
- popOff();
- return;
-
- case TREC_HEADER:
- *c = (StgClosure *)((StgTRecHeader *)se->c)->current_chunk;
- *cp = se->c;
- *r = se->c_child_r;
- popOff();
- return;
-
case TREC_CHUNK: {
// These are pretty complicated: we have N entries, each
// of which contains 3 fields that we want to follow. So
// we divide the step counter: the 2 low bits indicate
// which field, and the rest of the bits indicate the
// entry number (starting from zero).
+ TRecEntry *entry;
nat entry_no = se->info.next.step >> 2;
nat field_no = se->info.next.step & 3;
if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
popOff();
return;
}
- TRecEntry *entry = &((StgTRecChunk *)se->c)->entries[entry_no];
+ entry = &((StgTRecChunk *)se->c)->entries[entry_no];
if (field_no == 0) {
*c = (StgClosure *)entry->tvar;
} else if (field_no == 1) {
}
case CONSTR:
- case STABLE_NAME:
+ case PRIM:
+ case MUT_PRIM:
case BCO:
case CONSTR_STATIC:
// StgMutArrPtr.ptrs, no SRT
// no child (fixed), no SRT
case CONSTR_0_1:
case CONSTR_0_2:
- case CAF_BLACKHOLE:
- case BLACKHOLE:
- case SE_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
case ARR_WORDS:
// one child (fixed), no SRT
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
case THUNK_SELECTOR:
case IND_PERM:
- case IND_OLDGEN_PERM:
- case IND_OLDGEN:
case CONSTR_1_1:
// cannot appear
case PAP:
case AP:
case AP_STACK:
case TSO:
- case IND_STATIC:
+ case STACK:
+ case IND_STATIC:
case CONSTR_NOCAF_STATIC:
// stack objects
case RET_DYN:
case UPDATE_FRAME:
case CATCH_FRAME:
- case STOP_FRAME:
+ case UNDERFLOW_FRAME:
+ case STOP_FRAME:
case RET_BCO:
case RET_SMALL:
- case RET_VEC_SMALL:
case RET_BIG:
- case RET_VEC_BIG:
// invalid objects
case IND:
- case BLOCKED_FETCH:
- case FETCH_ME:
- case FETCH_ME_BQ:
- case RBH:
- case REMOTE_REF:
- case EVACUATED:
case INVALID_OBJECT:
default:
barf("Invalid object *c in pop()");
//
// TSOs MUST be retainers: they constitute the set of roots.
case TSO:
+ case STACK:
// mutable objects
- case MVAR:
+ case MUT_PRIM:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
case MUT_ARR_PTRS_CLEAN:
// WEAK objects are roots; there is separate code in which traversing
// begins from WEAK objects.
case WEAK:
-
- // Since the other mutvar-type things are retainers, seems
- // like the right thing to do:
- case TVAR:
return rtsTrue;
//
case FUN_0_2:
// partial applications
case PAP:
- // blackholes
- case CAF_BLACKHOLE:
- case BLACKHOLE:
- case SE_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
// indirection
case IND_PERM:
- case IND_OLDGEN_PERM:
- case IND_OLDGEN:
+ // IND_STATIC used to be an error, but at the moment it can happen
+ // as isAlive doesn't look through IND_STATIC as it ignores static
+ // closures. See trac #3956 for a program that hit this error.
+ case IND_STATIC:
+ case BLACKHOLE:
// static objects
case CONSTR_STATIC:
case FUN_STATIC:
// misc
- case STABLE_NAME:
+ case PRIM:
case BCO:
case ARR_WORDS:
// STM
- case TVAR_WATCH_QUEUE:
- case TREC_HEADER:
case TREC_CHUNK:
return rtsFalse;
//
// Error case
//
- // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
- case IND_STATIC:
// CONSTR_NOCAF_STATIC
// cannot be *c, *cp, *r in the retainer profiling loop.
case CONSTR_NOCAF_STATIC:
// legal objects during retainer profiling.
case UPDATE_FRAME:
case CATCH_FRAME:
+ case UNDERFLOW_FRAME:
case STOP_FRAME:
case RET_DYN:
case RET_BCO:
case RET_SMALL:
- case RET_VEC_SMALL:
case RET_BIG:
- case RET_VEC_BIG:
// other cases
case IND:
- case BLOCKED_FETCH:
- case FETCH_ME:
- case FETCH_ME_BQ:
- case RBH:
- case REMOTE_REF:
- case EVACUATED:
case INVALID_OBJECT:
default:
barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
while (bitmap != 0) {
if ((bitmap & 1) != 0) {
-#ifdef ENABLE_WIN32_DLL_SUPPORT
+#if defined(__PIC__) && defined(mingw32_HOST_OS)
if ( (unsigned long)(*srt) & 0x1 ) {
- retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
+ retainClosure(* (StgClosure**) ((unsigned long) (*srt) & ~0x1),
c, c_child_r);
} else {
retainClosure(*srt,c,c_child_r);
* RSET(c) and RSET(c_child_r) are valid, i.e., their
* interpretation conforms to the current value of flip (even when they
* are interpreted to be NULL).
- * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
- * or ThreadKilled, which means that its stack is ready to process.
+ * If *c is TSO, its state is not ThreadComplete,or ThreadKilled,
+ * which means that its stack is ready to process.
* Note:
* This code was almost plagiarzied from GC.c! For each pointer,
* retainClosure() is invoked instead of evacuate().
stackElement *oldStackBoundary;
StgPtr p;
StgRetInfoTable *info;
- StgWord32 bitmap;
+ StgWord bitmap;
nat size;
#ifdef DEBUG_RETAINER
// debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
#endif
- ASSERT(get_itbl(c)->type != TSO ||
- (((StgTSO *)c)->what_next != ThreadRelocated &&
- ((StgTSO *)c)->what_next != ThreadComplete &&
- ((StgTSO *)c)->what_next != ThreadKilled));
-
+ ASSERT(get_itbl(c)->type == STACK);
+
p = stackStart;
while (p < stackEnd) {
info = get_ret_itbl((StgClosure *)p);
p += sizeofW(StgUpdateFrame);
continue;
- case STOP_FRAME:
+ case UNDERFLOW_FRAME:
+ case STOP_FRAME:
case CATCH_FRAME:
case CATCH_STM_FRAME:
case CATCH_RETRY_FRAME:
case ATOMICALLY_FRAME:
case RET_SMALL:
- case RET_VEC_SMALL:
bitmap = BITMAP_BITS(info->i.layout.bitmap);
size = BITMAP_SIZE(info->i.layout.bitmap);
p++;
// large bitmap (> 32 entries, or > 64 on a 64-bit machine)
case RET_BIG:
- case RET_VEC_BIG:
size = GET_LARGE_BITMAP(&info->i)->size;
p++;
retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
StgFunInfoTable *fun_info;
retainClosure(ret_fun->fun, c, c_child_r);
- fun_info = get_fun_itbl(ret_fun->fun);
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
p = (P_)&ret_fun->payload;
switch (fun_info->f.fun_type) {
* ------------------------------------------------------------------------- */
static INLINE StgPtr
-retain_PAP_payload (StgClosure *pap, retainer c_child_r, StgClosure *fun,
+retain_PAP_payload (StgClosure *pap, /* NOT tagged */
+ retainer c_child_r, /* NOT tagged */
+ StgClosure *fun, /* tagged */
StgClosure** payload, StgWord n_args)
{
StgPtr p;
StgFunInfoTable *fun_info;
retainClosure(fun, pap, c_child_r);
+ fun = UNTAG_CLOSURE(fun);
fun_info = get_fun_itbl(fun);
ASSERT(fun_info->i.type != PAP);
static void
retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
{
- // c = Current closure
- // cp = Current closure's Parent
- // r = current closures' most recent Retainer
+ // c = Current closure (possibly tagged)
+ // cp = Current closure's Parent (NOT tagged)
+ // r = current closures' most recent Retainer (NOT tagged)
// c_child_r = current closure's children's most recent retainer
// first_child = first child of c
StgClosure *c, *cp, *first_child;
//debugBelch("inner_loop");
inner_loop:
+ c = UNTAG_CLOSURE(c);
+
// c = current closure under consideration,
// cp = current closure's parent,
// r = current closure's most recent retainer
#endif
goto loop;
}
- if (((StgTSO *)c)->what_next == ThreadRelocated) {
-#ifdef DEBUG_RETAINER
- debugBelch("ThreadRelocated encountered in retainClosure()\n");
-#endif
- c = (StgClosure *)((StgTSO *)c)->link;
- goto inner_loop;
- }
- break;
+ break;
case IND_STATIC:
// We just skip IND_STATIC, so its retainer set is never computed.
// than attempting to save the current position, because doing so
// would be hard.
switch (typeOfc) {
- case TSO:
+ case STACK:
retainStack(c, c_child_r,
- ((StgTSO *)c)->sp,
- ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
+ ((StgStack *)c)->sp,
+ ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
goto loop;
+ case TSO:
+ {
+ StgTSO *tso = (StgTSO *)c;
+
+ retainClosure(tso->stackobj, c, c_child_r);
+ retainClosure(tso->blocked_exceptions, c, c_child_r);
+ retainClosure(tso->bq, c, c_child_r);
+ retainClosure(tso->trec, c, c_child_r);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole
+ || tso->why_blocked == BlockedOnMsgThrowTo
+ ) {
+ retainClosure(tso->block_info.closure, c, c_child_r);
+ }
+ goto loop;
+ }
+
case PAP:
{
StgPAP *pap = (StgPAP *)c;
* Compute the retainer set for every object reachable from *tl.
* -------------------------------------------------------------------------- */
static void
-retainRoot( StgClosure **tl )
+retainRoot(void *user STG_UNUSED, StgClosure **tl)
{
+ StgClosure *c;
+
// We no longer assume that only TSOs and WEAKs are roots; any closure can
// be a root.
ASSERT(isEmptyRetainerStack());
currentStackBoundary = stackTop;
- if (*tl != &stg_END_TSO_QUEUE_closure && isRetainer(*tl)) {
- retainClosure(*tl, *tl, getRetainerFrom(*tl));
+ c = UNTAG_CLOSURE(*tl);
+ if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
+ retainClosure(c, c, getRetainerFrom(c));
} else {
- retainClosure(*tl, *tl, CCS_SYSTEM);
+ retainClosure(c, c, CCS_SYSTEM);
}
// NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
{
StgWeak *weak;
RetainerSet *rtl;
- nat g;
+ nat g, n;
StgPtr ml;
bdescr *bd;
#ifdef DEBUG_RETAINER
RetainerSet tmpRetainerSet;
#endif
- GetRoots(retainRoot); // for scheduler roots
+ markCapabilities(retainRoot, NULL); // for scheduler roots
// This function is called after a major GC, when key, value, and finalizer
// all are guaranteed to be valid, or reachable.
// for retainer profilng.
for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
// retainRoot((StgClosure *)weak);
- retainRoot((StgClosure **)&weak);
+ retainRoot(NULL, (StgClosure **)&weak);
// Consider roots from the stable ptr table.
- markStablePtrTable(retainRoot);
+ markStablePtrTable(retainRoot, NULL);
// The following code resets the rs field of each unvisited mutable
// object (computing sumOfNewCostExtra and updating costArray[] when
// Traversing through mut_list is necessary
// because we can find MUT_VAR objects which have not been
// visited during retainer profiling.
- for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
+ for (n = 0; n < n_capabilities; n++) {
+ for (bd = capabilities[n].mut_lists[g]; bd != NULL; bd = bd->link) {
for (ml = bd->start; ml < bd->free; ml++) {
maybeInitRetainerSet((StgClosure *)*ml);
}
#endif
}
- }
+ }
+ }
}
}
* they are not taken into consideration in computing retainer sets.
* -------------------------------------------------------------------------- */
void
-resetStaticObjectForRetainerProfiling( void )
+resetStaticObjectForRetainerProfiling( StgClosure *static_objects )
{
#ifdef DEBUG_RETAINER
nat count;
#ifdef DEBUG_RETAINER
count = 0;
#endif
- p = scavenged_static_objects;
+ p = static_objects;
while (p != END_OF_STATIC_LIST) {
#ifdef DEBUG_RETAINER
count++;
if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
if (get_itbl(c)->type == CONSTR &&
- !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
- !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
+ !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
+ !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
costArray[get_itbl(c)->type] += cost(c);
sumOfNewCost += cost(c);
debugBelch(
"Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
flip, c, get_itbl(c)->type,
- get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
+ get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
RSET(c));
} else {
// debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
StgPtr p;
static nat costSum, size;
- bd = small_alloc_list;
+ bd = g0s0->blocks;
costSum = 0;
// first block
projects / ghc-hetmet.git / blobdiff