rts: Split heap traversal from retainer profiler

This finally moves the newly generalised heap traversal code from the
retainer profiler into it's own file.

3 files changed, 1372 insertions, 1353 deletions

diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c
index 301f712e59..6f053c09c4 100644
--- a/rts/RetainerProfile.c
+++ b/rts/RetainerProfile.c
@@ -66,41 +66,6 @@ static uint32_t numObjectVisited;    // total number of objects visited
 static uint32_t timesAnyObjectVisited;  // number of times any objects are
                                         // visited
 
-/** Note [Profiling heap traversal visited bit]
- *
- * If the RTS is compiled with profiling enabled StgProfHeader can be used by
- * profiling code to store per-heap object information.
- *
- * The generic heap traversal code reserves the least significant bit of the
- * largest members of the 'trav' union to decide whether we've already visited a
- * given closure in the current pass or not. The rest of the field is free to be
- * used by the calling profiler.
- *
- * By doing things this way we implicitly assume that the LSB of the largest
- * field in the 'trav' union is insignificant. This is true at least for the
- * word aligned pointers which the retainer profiler currently stores there and
- * should be maintained by new users of the 'trav' union for example by shifting
- * the real data up by one bit.
- *
- * Since we don't want to have to scan the entire heap a second time just to
- * reset the per-object visitied bit before/after the real traversal we make the
- * interpretation of this bit dependent on the value of a global variable,
- * 'flip'.
- *
- * When the 'trav' bit is equal to the value of 'flip' the closure data is
- * valid otherwise not (see isTravDataValid). We then invert the value of 'flip'
- * on each heap traversal (see traverseWorkStack), in effect marking all
- * closure's data as invalid at once.
- *
- * There are some complications with this approach, namely: static objects and
- * mutable data. There we do just go over all existing objects to reset the bit
- * manually. See 'resetStaticObjectForProfiling' and 'computeRetainerSet'.
- */
-StgWord flip = 0;
-
-#define setTravDataToZero(c) \
-  (c)->header.prof.hp.trav.lsb = flip
-
 /* -----------------------------------------------------------------------------
  * Retainer stack - header
  *   Note:
@@ -111,181 +76,8 @@ StgWord flip = 0;
  *     all.
  * -------------------------------------------------------------------------- */
 
-typedef enum {
-    // Object with fixed layout. Keeps an information about that
-    // element was processed. (stackPos.next.step)
-    posTypeStep,
-    // Description of the pointers-first heap object. Keeps information
-    // about layout. (stackPos.next.ptrs)
-    posTypePtrs,
-    // Keeps SRT bitmap (stackPos.next.srt)
-    posTypeSRT,
-    // Keeps a new object that was not inspected yet. Keeps a parent
-    // element (stackPos.next.parent)
-    posTypeFresh
-} nextPosType;
-
-typedef union {
-    // fixed layout or layout specified by a field in the closure
-    StgWord step;
-
-    // layout.payload
-    struct {
-        // See StgClosureInfo in InfoTables.h
-        StgHalfWord pos;
-        StgHalfWord ptrs;
-        StgPtr payload;
-    } ptrs;
-
-    // SRT
-    struct {
-        StgClosure *srt;
-    } srt;
-} nextPos;
-
-/**
- * Position pointer into a closure. Determines what the next element to return
- * for a stackElement is.
- */
-typedef struct {
-    nextPosType type;
-    nextPos next;
-} stackPos;
-
-/**
- * An element of the traversal work-stack. Besides the closure itself this also
- * stores it's parent and associated data.
- *
- * When 'info.type == posTypeFresh' a 'stackElement' represents just one
- * closure, namely 'c' and 'cp' being it's parent. Otherwise 'info' specifies an
- * offset into the children of 'c'. This is to support returning a closure's
- * children one-by-one without pushing one element per child onto the stack. See
- * traversePushChildren() and traversePop().
- *
- */
-typedef struct stackElement_ {
-    stackPos info;
-    StgClosure *c;
-    StgClosure *cp; // parent of 'c'. Only used when info.type == posTypeFresh.
-    stackData data;
-} stackElement;
-
 traverseState g_retainerTraverseState;
 
-
-#if defined(DEBUG)
-unsigned int g_traversalDebugLevel = 0;
-static inline void debug(const char *s, ...)
-{
-    va_list ap;
-
-    if(g_traversalDebugLevel == 0)
-        return;
-
-    va_start(ap,s);
-    vdebugBelch(s, ap);
-    va_end(ap);
-}
-#else
-#define debug(...)
-#endif
-
-// number of blocks allocated for one stack
-#define BLOCKS_IN_STACK 1
-
-/* -----------------------------------------------------------------------------
- * Add a new block group to the stack.
- * Invariants:
- *  currentStack->link == s.
- * -------------------------------------------------------------------------- */
-STATIC_INLINE void
-newStackBlock( traverseState *ts, bdescr *bd )
-{
-    ts->currentStack = bd;
-    ts->stackTop     = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
-    ts->stackBottom  = (stackElement *)bd->start;
-    ts->stackLimit   = (stackElement *)ts->stackTop;
-    bd->free     = (StgPtr)ts->stackLimit;
-}
-
-/* -----------------------------------------------------------------------------
- * Return to the previous block group.
- * Invariants:
- *   s->link == currentStack.
- * -------------------------------------------------------------------------- */
-STATIC_INLINE void
-returnToOldStack( traverseState *ts, bdescr *bd )
-{
-    ts->currentStack = bd;
-    ts->stackTop = (stackElement *)bd->free;
-    ts->stackBottom = (stackElement *)bd->start;
-    ts->stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
-    bd->free = (StgPtr)ts->stackLimit;
-}
-
-/**
- *  Initializes the traversal work-stack.
- */
-void
-initializeTraverseStack( traverseState *ts )
-{
-    if (ts->firstStack != NULL) {
-        freeChain(ts->firstStack);
-    }
-
-    ts->firstStack = allocGroup(BLOCKS_IN_STACK);
-    ts->firstStack->link = NULL;
-    ts->firstStack->u.back = NULL;
-
-    ts->stackSize = 0;
-    ts->maxStackSize = 0;
-
-    newStackBlock(ts, ts->firstStack);
-}
-
-/**
- * Frees all the block groups in the traversal works-stack.
- *
- * Invariants:
- *   firstStack != NULL
- */
-void
-closeTraverseStack( traverseState *ts )
-{
-    freeChain(ts->firstStack);
-    ts->firstStack = NULL;
-}
-
-int
-getTraverseStackMaxSize(traverseState *ts)
-{
-    return ts->maxStackSize;
-}
-
-/* -----------------------------------------------------------------------------
- * Returns true if the whole stack is empty.
- * -------------------------------------------------------------------------- */
-STATIC_INLINE bool
-isEmptyWorkStack( traverseState *ts )
-{
-    return (ts->firstStack == ts->currentStack) && ts->stackTop == ts->stackLimit;
-}
-
-/* -----------------------------------------------------------------------------
- * Returns size of stack
- * -------------------------------------------------------------------------- */
-W_
-traverseWorkStackBlocks(traverseState *ts)
-{
-    bdescr* bd;
-    W_ res = 0;
-
-    for (bd = ts->firstStack; bd != NULL; bd = bd->link)
-      res += bd->blocks;
-
-    return res;
-}
-
 W_
 retainerStackBlocks(void)
 {
@@ -293,648 +85,6 @@ retainerStackBlocks(void)
 }
 
 /* -----------------------------------------------------------------------------
- * Initializes *info from ptrs and payload.
- * Invariants:
- *   payload[] begins with ptrs pointers followed by non-pointers.
- * -------------------------------------------------------------------------- */
-STATIC_INLINE void
-init_ptrs( stackPos *info, uint32_t ptrs, StgPtr payload )
-{
-    info->type              = posTypePtrs;
-    info->next.ptrs.pos     = 0;
-    info->next.ptrs.ptrs    = ptrs;
-    info->next.ptrs.payload = payload;
-}
-
-/* -----------------------------------------------------------------------------
- * Find the next object from *info.
- * -------------------------------------------------------------------------- */
-STATIC_INLINE StgClosure *
-find_ptrs( stackPos *info )
-{
-    if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
-        return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
-    } else {
-        return NULL;
-    }
-}
-
-/* -----------------------------------------------------------------------------
- *  Initializes *info from SRT information stored in *infoTable.
- * -------------------------------------------------------------------------- */
-STATIC_INLINE void
-init_srt_fun( stackPos *info, const StgFunInfoTable *infoTable )
-{
-    info->type = posTypeSRT;
-    if (infoTable->i.srt) {
-        info->next.srt.srt = (StgClosure*)GET_FUN_SRT(infoTable);
-    } else {
-        info->next.srt.srt = NULL;
-    }
-}
-
-STATIC_INLINE void
-init_srt_thunk( stackPos *info, const StgThunkInfoTable *infoTable )
-{
-    info->type = posTypeSRT;
-    if (infoTable->i.srt) {
-        info->next.srt.srt = (StgClosure*)GET_SRT(infoTable);
-    } else {
-        info->next.srt.srt = NULL;
-    }
-}
-
-/* -----------------------------------------------------------------------------
- * Find the next object from *info.
- * -------------------------------------------------------------------------- */
-STATIC_INLINE StgClosure *
-find_srt( stackPos *info )
-{
-    StgClosure *c;
-    if (info->type == posTypeSRT) {
-        c = info->next.srt.srt;
-        info->next.srt.srt = NULL;
-        return c;
-    }
-
-    return NULL;
-}
-
-/**
- * Push a set of closures, represented by a single 'stackElement', onto the
- * traversal work-stack.
- */
-static void
-pushStackElement(traverseState *ts, stackElement *se)
-{
-    bdescr *nbd;      // Next Block Descriptor
-    if (ts->stackTop - 1 < ts->stackBottom) {
-        debug("pushStackElement() to the next stack.\n");
-
-        // currentStack->free is updated when the active stack is switched
-        // to the next stack.
-        ts->currentStack->free = (StgPtr)ts->stackTop;
-
-        if (ts->currentStack->link == NULL) {
-            nbd = allocGroup(BLOCKS_IN_STACK);
-            nbd->link = NULL;
-            nbd->u.back = ts->currentStack;
-            ts->currentStack->link = nbd;
-        } else
-            nbd = ts->currentStack->link;
-
-        newStackBlock(ts, nbd);
-    }
-
-    // adjust stackTop (acutal push)
-    ts->stackTop--;
-    // If the size of stackElement was huge, we would better replace the
-    // following statement by either a memcpy() call or a switch statement
-    // on the type of the element. Currently, the size of stackElement is
-    // small enough (5 words) that this direct assignment seems to be enough.
-    *ts->stackTop = *se;
-
-    ts->stackSize++;
-    if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
-    ASSERT(ts->stackSize >= 0);
-    debug("stackSize = %d\n", ts->stackSize);
-}
-
-/**
- * Push a single closure onto the traversal work-stack.
- *
- *  cp   - object's parent
- *  c    - closure
- *  data - data associated with closure.
- */
-inline void
-traversePushClosure(traverseState *ts, StgClosure *c, StgClosure *cp, stackData data) {
-    stackElement se;
-
-    se.c = c;
-    se.cp = cp;
-    se.data = data;
-    se.info.type = posTypeFresh;
-
-    pushStackElement(ts, &se);
-};
-
-/**
- * traversePushChildren() extracts the first child of 'c' in 'first_child' and
- * conceptually pushes all remaining children of 'c' onto the traversal stack
- * while associating 'data' with the pushed elements to be returned upon poping.
- *
- * If 'c' has no children, 'first_child' is set to NULL and nothing is pushed
- * onto the stack.
- *
- * If 'c' has only one child, 'first_child' is set to that child and nothing is
- * pushed onto the stack.
- *
- * Invariants:
- *
- *  - 'c' is not any of TSO, AP, PAP, AP_STACK, which means that there cannot
- *       be any stack objects.
- *
- * Note: SRTs are considered to be children as well.
- *
- * Note: When pushing onto the stack we only really push one 'stackElement'
- * representing all children onto the stack. See traversePop()
- */
-STATIC_INLINE void
-traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosure **first_child)
-{
-    stackElement se;
-
-    debug("traversePushChildren(): stackTop = 0x%x\n", ts->stackTop);
-
-    ASSERT(get_itbl(c)->type != TSO);
-    ASSERT(get_itbl(c)->type != AP_STACK);
-
-    //
-    // fill in se
-    //
-
-    se.c = c;
-    se.data = data;
-    // Note: se.cp ommitted on purpose, only traversePushClosure uses that.
-
-    // fill in se.info
-    switch (get_itbl(c)->type) {
-        // no child, no SRT
-    case CONSTR_0_1:
-    case CONSTR_0_2:
-    case ARR_WORDS:
-    case COMPACT_NFDATA:
-        *first_child = NULL;
-        return;
-
-        // one child (fixed), no SRT
-    case MUT_VAR_CLEAN:
-    case MUT_VAR_DIRTY:
-        *first_child = ((StgMutVar *)c)->var;
-        return;
-    case THUNK_SELECTOR:
-        *first_child = ((StgSelector *)c)->selectee;
-        return;
-    case BLACKHOLE:
-        *first_child = ((StgInd *)c)->indirectee;
-        return;
-    case CONSTR_1_0:
-    case CONSTR_1_1:
-        *first_child = c->payload[0];
-        return;
-
-        // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
-        // of the next child. We do not write a separate initialization code.
-        // Also we do not have to initialize info.type;
-
-        // two children (fixed), no SRT
-        // need to push a stackElement, but nothing to store in se.info
-    case CONSTR_2_0:
-        *first_child = c->payload[0];         // return the first pointer
-        se.info.type = posTypeStep;
-        se.info.next.step = 2;            // 2 = second
-        break;
-
-        // three children (fixed), no SRT
-        // need to push a stackElement
-    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;
-        se.info.type = posTypeStep;
-        se.info.next.step = 2;            // 2 = second
-        break;
-
-        // three children (fixed), no SRT
-    case WEAK:
-        *first_child = ((StgWeak *)c)->key;
-        se.info.type = posTypeStep;
-        se.info.next.step = 2;
-        break;
-
-        // layout.payload.ptrs, no SRT
-    case TVAR:
-    case CONSTR:
-    case CONSTR_NOCAF:
-    case PRIM:
-    case MUT_PRIM:
-    case BCO:
-        init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
-                  (StgPtr)c->payload);
-        *first_child = find_ptrs(&se.info);
-        if (*first_child == NULL)
-            return;   // no child
-        break;
-
-        // StgMutArrPtr.ptrs, no SRT
-    case MUT_ARR_PTRS_CLEAN:
-    case MUT_ARR_PTRS_DIRTY:
-    case MUT_ARR_PTRS_FROZEN_CLEAN:
-    case MUT_ARR_PTRS_FROZEN_DIRTY:
-        init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
-                  (StgPtr)(((StgMutArrPtrs *)c)->payload));
-        *first_child = find_ptrs(&se.info);
-        if (*first_child == NULL)
-            return;
-        break;
-
-        // StgMutArrPtr.ptrs, no SRT
-    case SMALL_MUT_ARR_PTRS_CLEAN:
-    case SMALL_MUT_ARR_PTRS_DIRTY:
-    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
-    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
-        init_ptrs(&se.info, ((StgSmallMutArrPtrs *)c)->ptrs,
-                  (StgPtr)(((StgSmallMutArrPtrs *)c)->payload));
-        *first_child = find_ptrs(&se.info);
-        if (*first_child == NULL)
-            return;
-        break;
-
-    // layout.payload.ptrs, SRT
-    case FUN_STATIC:
-    case FUN:           // *c is a heap object.
-    case FUN_2_0:
-        init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
-        *first_child = find_ptrs(&se.info);
-        if (*first_child == NULL)
-            // no child from ptrs, so check SRT
-            goto fun_srt_only;
-        break;
-
-    case THUNK:
-    case THUNK_2_0:
-        init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
-                  (StgPtr)((StgThunk *)c)->payload);
-        *first_child = find_ptrs(&se.info);
-        if (*first_child == NULL)
-            // no child from ptrs, so check SRT
-            goto thunk_srt_only;
-        break;
-
-        // 1 fixed child, SRT
-    case FUN_1_0:
-    case FUN_1_1:
-        *first_child = c->payload[0];
-        ASSERT(*first_child != NULL);
-        init_srt_fun(&se.info, get_fun_itbl(c));
-        break;
-
-    case THUNK_1_0:
-    case THUNK_1_1:
-        *first_child = ((StgThunk *)c)->payload[0];
-        ASSERT(*first_child != NULL);
-        init_srt_thunk(&se.info, get_thunk_itbl(c));
-        break;
-
-    case FUN_0_1:      // *c is a heap object.
-    case FUN_0_2:
-    fun_srt_only:
-        init_srt_fun(&se.info, get_fun_itbl(c));
-        *first_child = find_srt(&se.info);
-        if (*first_child == NULL)
-            return;     // no child
-        break;
-
-    // SRT only
-    case THUNK_STATIC:
-        ASSERT(get_itbl(c)->srt != 0);
-        /* fall-thru */
-    case THUNK_0_1:
-    case THUNK_0_2:
-    thunk_srt_only:
-        init_srt_thunk(&se.info, get_thunk_itbl(c));
-        *first_child = find_srt(&se.info);
-        if (*first_child == NULL)
-            return;     // no child
-        break;
-
-    case TREC_CHUNK:
-        *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
-        se.info.type = posTypeStep;
-        se.info.next.step = 0;  // entry no.
-        break;
-
-        // cannot appear
-    case PAP:
-    case AP:
-    case AP_STACK:
-    case TSO:
-    case STACK:
-    case IND_STATIC:
-        // stack objects
-    case UPDATE_FRAME:
-    case CATCH_FRAME:
-    case UNDERFLOW_FRAME:
-    case STOP_FRAME:
-    case RET_BCO:
-    case RET_SMALL:
-    case RET_BIG:
-        // invalid objects
-    case IND:
-    case INVALID_OBJECT:
-    default:
-        barf("Invalid object *c in push(): %d", get_itbl(c)->type);
-        return;
-    }
-
-    // se.cp has to be initialized when type==posTypeFresh. We don't do that
-    // here though. So type must be !=posTypeFresh.
-    ASSERT(se.info.type != posTypeFresh);
-
-    pushStackElement(ts, &se);
-}
-
-/**
- *  popStackElement(): Remove a depleted stackElement from the top of the
- *  traversal work-stack.
- *
- *  Invariants:
- *    stackTop cannot be equal to stackLimit unless the whole stack is
- *    empty, in which case popStackElement() is not allowed.
- */
-static void
-popStackElement(traverseState *ts) {
-    debug("popStackElement(): stackTop = 0x%x\n", ts->stackTop);
-
-    ASSERT(ts->stackTop != ts->stackLimit);
-    ASSERT(!isEmptyWorkStack(ts));
-
-    // <= (instead of <) is wrong!
-    if (ts->stackTop + 1 < ts->stackLimit) {
-        ts->stackTop++;
-
-        ts->stackSize--;
-        if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
-        ASSERT(ts->stackSize >= 0);
-        debug("stackSize = (--) %d\n", ts->stackSize);
-
-        return;
-    }
-
-    bdescr *pbd;    // Previous Block Descriptor
-
-    debug("popStackElement() to the previous stack.\n");
-
-    ASSERT(ts->stackTop + 1 == ts->stackLimit);
-    ASSERT(ts->stackBottom == (stackElement *)ts->currentStack->start);
-
-    if (ts->firstStack == ts->currentStack) {
-        // The stack is completely empty.
-        ts->stackTop++;
-        ASSERT(ts->stackTop == ts->stackLimit);
-
-        ts->stackSize--;
-        if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
-        ASSERT(ts->stackSize >= 0);
-        debug("stackSize = %d\n", ts->stackSize);
-
-        return;
-    }
-
-    // currentStack->free is updated when the active stack is switched back
-    // to the previous stack.
-    ts->currentStack->free = (StgPtr)ts->stackLimit;
-
-    // find the previous block descriptor
-    pbd = ts->currentStack->u.back;
-    ASSERT(pbd != NULL);
-
-    returnToOldStack(ts, pbd);
-
-    ts->stackSize--;
-    if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
-    ASSERT(ts->stackSize >= 0);
-    debug("stackSize = %d\n", ts->stackSize);
-}
-
-/**
- *  Finds the next object to be considered for retainer profiling and store
- *  its pointer to *c.
- *
- *  If the unprocessed object was stored in the stack (posTypeFresh), the
- *  this object is returned as-is. Otherwise Test if the topmost stack
- *  element indicates that more objects are left,
- *  and if so, retrieve the first object and store its pointer to *c. Also,
- *  set *cp and *data appropriately, both of which are stored in the stack
- *  element.  The topmost stack element then is overwritten so as for it to now
- *  denote the next object.
- *
- *  If the topmost stack element indicates no more objects are left, pop
- *  off the stack element until either an object can be retrieved or
- *  the work-stack becomes empty, indicated by true returned by
- *  isEmptyWorkStack(), in which case *c is set to NULL.
- *
- *  Note:
- *
- *    It is okay to call this function even when the work-stack is empty.
- */
-STATIC_INLINE void
-traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data)
-{
-    stackElement *se;
-
-    debug("traversePop(): stackTop = 0x%x\n", ts->stackTop);
-
-    // Is this the last internal element? If so instead of modifying the current
-    // stackElement in place we actually remove it from the stack.
-    bool last = false;
-
-    do {
-        if (isEmptyWorkStack(ts)) {
-            *c = NULL;
-            return;
-        }
-
-        // Note: Below every `break`, where the loop condition is true, must be
-        // accompanied by a popStackElement() otherwise this is an infinite
-        // loop.
-        se = ts->stackTop;
-
-        // If this is a top-level element, you should pop that out.
-        if (se->info.type == posTypeFresh) {
-            *cp = se->cp;
-            *c = se->c;
-            *data = se->data;
-            popStackElement(ts);
-            return;
-        }
-
-        // Note: The first ptr of all of these was already returned as
-        // *fist_child in push(), so we always start with the second field.
-        switch (get_itbl(se->c)->type) {
-            // two children (fixed), no SRT
-            // nothing in se.info
-        case CONSTR_2_0:
-            *c = se->c->payload[1];
-            last = true;
-            goto out;
-
-            // three children (fixed), no SRT
-            // need to push a stackElement
-        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
-                // no popStackElement
-            } else {
-                *c = ((StgMVar *)se->c)->value;
-                last = true;
-            }
-            goto out;
-
-            // three children (fixed), no SRT
-        case WEAK:
-            if (se->info.next.step == 2) {
-                *c = ((StgWeak *)se->c)->value;
-                se->info.next.step++;
-                // no popStackElement
-            } else {
-                *c = ((StgWeak *)se->c)->finalizer;
-                last = true;
-            }
-            goto out;
-
-        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;
-            uint32_t entry_no = se->info.next.step >> 2;
-            uint32_t field_no = se->info.next.step & 3;
-            if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
-                *c = NULL;
-                popStackElement(ts);
-                break; // this breaks out of the switch not the loop
-            }
-            entry = &((StgTRecChunk *)se->c)->entries[entry_no];
-            if (field_no == 0) {
-                *c = (StgClosure *)entry->tvar;
-            } else if (field_no == 1) {
-                *c = entry->expected_value;
-            } else {
-                *c = entry->new_value;
-            }
-            se->info.next.step++;
-            goto out;
-        }
-
-        case TVAR:
-        case CONSTR:
-        case PRIM:
-        case MUT_PRIM:
-        case BCO:
-            // StgMutArrPtr.ptrs, no SRT
-        case MUT_ARR_PTRS_CLEAN:
-        case MUT_ARR_PTRS_DIRTY:
-        case MUT_ARR_PTRS_FROZEN_CLEAN:
-        case MUT_ARR_PTRS_FROZEN_DIRTY:
-        case SMALL_MUT_ARR_PTRS_CLEAN:
-        case SMALL_MUT_ARR_PTRS_DIRTY:
-        case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
-        case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
-            *c = find_ptrs(&se->info);
-            if (*c == NULL) {
-                popStackElement(ts);
-                break; // this breaks out of the switch not the loop
-            }
-            goto out;
-
-            // layout.payload.ptrs, SRT
-        case FUN:         // always a heap object
-        case FUN_STATIC:
-        case FUN_2_0:
-            if (se->info.type == posTypePtrs) {
-                *c = find_ptrs(&se->info);
-                if (*c != NULL) {
-                    goto out;
-                }
-                init_srt_fun(&se->info, get_fun_itbl(se->c));
-            }
-            goto do_srt;
-
-        case THUNK:
-        case THUNK_2_0:
-            if (se->info.type == posTypePtrs) {
-                *c = find_ptrs(&se->info);
-                if (*c != NULL) {
-                    goto out;
-                }
-                init_srt_thunk(&se->info, get_thunk_itbl(se->c));
-            }
-            goto do_srt;
-
-            // SRT
-        do_srt:
-        case THUNK_STATIC:
-        case FUN_0_1:
-        case FUN_0_2:
-        case THUNK_0_1:
-        case THUNK_0_2:
-        case FUN_1_0:
-        case FUN_1_1:
-        case THUNK_1_0:
-        case THUNK_1_1:
-            *c = find_srt(&se->info);
-            if(*c == NULL) {
-                popStackElement(ts);
-                break; // this breaks out of the switch not the loop
-            }
-            goto out;
-
-            // no child (fixed), no SRT
-        case CONSTR_0_1:
-        case CONSTR_0_2:
-        case ARR_WORDS:
-            // one child (fixed), no SRT
-        case MUT_VAR_CLEAN:
-        case MUT_VAR_DIRTY:
-        case THUNK_SELECTOR:
-        case CONSTR_1_1:
-            // cannot appear
-        case PAP:
-        case AP:
-        case AP_STACK:
-        case TSO:
-        case STACK:
-        case IND_STATIC:
-        case CONSTR_NOCAF:
-            // stack objects
-        case UPDATE_FRAME:
-        case CATCH_FRAME:
-        case UNDERFLOW_FRAME:
-        case STOP_FRAME:
-        case RET_BCO:
-        case RET_SMALL:
-        case RET_BIG:
-            // invalid objects
-        case IND:
-        case INVALID_OBJECT:
-        default:
-            barf("Invalid object *c in traversePop(): %d", get_itbl(se->c)->type);
-            return;
-        }
-    } while (*c == NULL);
-
-out:
-
-    ASSERT(*c != NULL);
-
-    *cp = se->c;
-    *data = se->data;
-
-    if(last)
-        popStackElement(ts);
-
-    return;
-
-}
-
-/* -----------------------------------------------------------------------------
  * RETAINER PROFILING ENGINE
  * -------------------------------------------------------------------------- */
 
@@ -954,22 +104,6 @@ endRetainerProfiling( void )
     outputAllRetainerSet(prof_file);
 }
 
-/**
- * Make sure a closure's profiling data is initialized to zero if it does not
- * conform to the current value of the flip bit, returns true in this case.
- *
- * See Note [Profiling heap traversal visited bit].
- */
-bool
-traverseMaybeInitClosureData(StgClosure *c)
-{
-    if (!isTravDataValid(c)) {
-        setTravDataToZero(c);
-        return true;
-    }
-    return false;
-}
-
 /* -----------------------------------------------------------------------------
  * Returns true if *c is a retainer.
  * In general the retainers are the objects that may be the roots of the
@@ -1120,214 +254,6 @@ associate( StgClosure *c, RetainerSet *s )
     RSET(c) = (RetainerSet *)((StgWord)s | flip);
 }
 
-/* -----------------------------------------------------------------------------
-   Call traversePushClosure for each of the closures covered by a large bitmap.
-   -------------------------------------------------------------------------- */
-
-static void
-traverseLargeBitmap (traverseState *ts, StgPtr p, StgLargeBitmap *large_bitmap,
-                     uint32_t size, StgClosure *c, stackData data)
-{
-    uint32_t i, b;
-    StgWord bitmap;
-
-    b = 0;
-    bitmap = large_bitmap->bitmap[b];
-    for (i = 0; i < size; ) {
-        if ((bitmap & 1) == 0) {
-            traversePushClosure(ts, (StgClosure *)*p, c, data);
-        }
-        i++;
-        p++;
-        if (i % BITS_IN(W_) == 0) {
-            b++;
-            bitmap = large_bitmap->bitmap[b];
-        } else {
-            bitmap = bitmap >> 1;
-        }
-    }
-}
-
-STATIC_INLINE StgPtr
-traverseSmallBitmap (traverseState *ts, StgPtr p, uint32_t size, StgWord bitmap,
-                     StgClosure *c, stackData data)
-{
-    while (size > 0) {
-        if ((bitmap & 1) == 0) {
-            traversePushClosure(ts, (StgClosure *)*p, c, data);
-        }
-        p++;
-        bitmap = bitmap >> 1;
-        size--;
-    }
-    return p;
-}
-
-/**
- *  traversePushStack(ts, cp, data, stackStart, stackEnd) pushes all the objects
- *  in the STG stack-chunk from stackStart to stackEnd onto the traversal
- *  work-stack with 'c' and 'data' being their parent and associated data,
- *  respectively.
- *
- *  Invariants:
- *
- *    *cp is one of the following: TSO, AP_STACK.
- *
- *    stackStart < stackEnd.
- *
- *    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,
- *    traversePushClosure() is invoked instead of evacuate().
- */
-static void
-traversePushStack(traverseState *ts, StgClosure *cp, stackData data,
-                  StgPtr stackStart, StgPtr stackEnd)
-{
-    StgPtr p;
-    const StgRetInfoTable *info;
-    StgWord bitmap;
-    uint32_t size;
-
-    ASSERT(get_itbl(cp)->type == STACK);
-
-    p = stackStart;
-    while (p < stackEnd) {
-        info = get_ret_itbl((StgClosure *)p);
-
-        switch(info->i.type) {
-
-        case UPDATE_FRAME:
-            traversePushClosure(ts, ((StgUpdateFrame *)p)->updatee, cp, data);
-            p += sizeofW(StgUpdateFrame);
-            continue;
-
-        case UNDERFLOW_FRAME:
-        case STOP_FRAME:
-        case CATCH_FRAME:
-        case CATCH_STM_FRAME:
-        case CATCH_RETRY_FRAME:
-        case ATOMICALLY_FRAME:
-        case RET_SMALL:
-            bitmap = BITMAP_BITS(info->i.layout.bitmap);
-            size   = BITMAP_SIZE(info->i.layout.bitmap);
-            p++;
-            p = traverseSmallBitmap(ts, p, size, bitmap, cp, data);
-
-        follow_srt:
-            if (info->i.srt) {
-                traversePushClosure(ts, GET_SRT(info), cp, data);
-            }
-            continue;
-
-        case RET_BCO: {
-            StgBCO *bco;
-
-            p++;
-            traversePushClosure(ts, (StgClosure*)*p, cp, data);
-            bco = (StgBCO *)*p;
-            p++;
-            size = BCO_BITMAP_SIZE(bco);
-            traverseLargeBitmap(ts, p, BCO_BITMAP(bco), size, cp, data);
-            p += size;
-            continue;
-        }
-
-            // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
-        case RET_BIG:
-            size = GET_LARGE_BITMAP(&info->i)->size;
-            p++;
-            traverseLargeBitmap(ts, p, GET_LARGE_BITMAP(&info->i),
-                                size, cp, data);
-            p += size;
-            // and don't forget to follow the SRT
-            goto follow_srt;
-
-        case RET_FUN: {
-            StgRetFun *ret_fun = (StgRetFun *)p;
-            const StgFunInfoTable *fun_info;
-
-            traversePushClosure(ts, ret_fun->fun, cp, data);
-            fun_info = get_fun_itbl(UNTAG_CONST_CLOSURE(ret_fun->fun));
-
-            p = (P_)&ret_fun->payload;
-            switch (fun_info->f.fun_type) {
-            case ARG_GEN:
-                bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
-                size = BITMAP_SIZE(fun_info->f.b.bitmap);
-                p = traverseSmallBitmap(ts, p, size, bitmap, cp, data);
-                break;
-            case ARG_GEN_BIG:
-                size = GET_FUN_LARGE_BITMAP(fun_info)->size;
-                traverseLargeBitmap(ts, p, GET_FUN_LARGE_BITMAP(fun_info),
-                                    size, cp, data);
-                p += size;
-                break;
-            default:
-                bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
-                size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
-                p = traverseSmallBitmap(ts, p, size, bitmap, cp, data);
-                break;
-            }
-            goto follow_srt;
-        }
-
-        default:
-            barf("Invalid object found in traversePushStack(): %d",
-                 (int)(info->i.type));
-        }
-    }
-}
-
-/* ----------------------------------------------------------------------------
- * Call traversePushClosure for each of the children of a PAP/AP
- * ------------------------------------------------------------------------- */
-
-STATIC_INLINE StgPtr
-traversePAP (traverseState *ts,
-                    StgClosure *pap,    /* NOT tagged */
-                    stackData data,
-                    StgClosure *fun,    /* tagged */
-                    StgClosure** payload, StgWord n_args)
-{
-    StgPtr p;
-    StgWord bitmap;
-    const StgFunInfoTable *fun_info;
-
-    traversePushClosure(ts, fun, pap, data);
-    fun = UNTAG_CLOSURE(fun);
-    fun_info = get_fun_itbl(fun);
-    ASSERT(fun_info->i.type != PAP);
-
-    p = (StgPtr)payload;
-
-    switch (fun_info->f.fun_type) {
-    case ARG_GEN:
-        bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
-        p = traverseSmallBitmap(ts, p, n_args, bitmap,
-                                pap, data);
-        break;
-    case ARG_GEN_BIG:
-        traverseLargeBitmap(ts, p, GET_FUN_LARGE_BITMAP(fun_info),
-                            n_args, pap, data);
-        p += n_args;
-        break;
-    case ARG_BCO:
-        traverseLargeBitmap(ts, (StgPtr)payload, BCO_BITMAP(fun),
-                            n_args, pap, data);
-        p += n_args;
-        break;
-    default:
-        bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
-        p = traverseSmallBitmap(ts, p, n_args, bitmap, pap, data);
-        break;
-    }
-    return p;
-}
-
 static bool
 retainVisitClosure( StgClosure *c, const StgClosure *cp, const stackData data, const bool first_visit, stackData *out_data )
 {
@@ -1408,219 +334,6 @@ retainVisitClosure( StgClosure *c, const StgClosure *cp, const stackData data, c
     return 1;
 }
 
-static void
-resetMutableObjects(void)
-{
-    uint32_t g, n;
-    bdescr *bd;
-    StgPtr ml;
-
-    // The following code resets the 'trav' field of each unvisited mutable
-    // object.
-    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
-        // NOT true: even G0 has a block on its mutable list
-        // ASSERT(g != 0 || (generations[g].mut_list == NULL));
-
-        // Traversing through mut_list is necessary
-        // because we can find MUT_VAR objects which have not been
-        // visited during heap traversal.
-        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++) {
-
-                traverseMaybeInitClosureData((StgClosure *)*ml);
-            }
-          }
-        }
-    }
-}
-
-/**
- * Traverse all closures on the traversal work-stack, calling 'visit_cb' on each
- * closure. See 'visitClosure_cb' for details. This function flips the 'flip'
- * bit and hence every closure's profiling data will be reset to zero upon
- * visiting. See Note [Profiling heap traversal visited bit].
- */
-void
-traverseWorkStack(traverseState *ts, visitClosure_cb visit_cb)
-{
-    // first_child = first child of c
-    StgClosure *c, *cp, *first_child;
-    stackData data, child_data;
-    StgWord typeOfc;
-
-    // Now we flip the flip bit.
-    flip = flip ^ 1;
-
-    // c = Current closure                           (possibly tagged)
-    // cp = Current closure's Parent                 (NOT tagged)
-    // data = current closures' associated data      (NOT tagged)
-    // data_out = data to associate with current closure's children
-
-loop:
-    traversePop(ts, &c, &cp, &data);
-
-    if (c == NULL) {
-        debug("maxStackSize= %d\n", ts->maxStackSize);
-        resetMutableObjects();
-        return;
-    }
-inner_loop:
-    c = UNTAG_CLOSURE(c);
-
-    typeOfc = get_itbl(c)->type;
-
-    // special cases
-    switch (typeOfc) {
-    case TSO:
-        if (((StgTSO *)c)->what_next == ThreadComplete ||
-            ((StgTSO *)c)->what_next == ThreadKilled) {
-            debug("ThreadComplete or ThreadKilled encountered in traverseWorkStack()\n");
-            goto loop;
-        }
-        break;
-
-    case IND_STATIC:
-        // We just skip IND_STATIC, so it's never visited.
-        c = ((StgIndStatic *)c)->indirectee;
-        goto inner_loop;
-
-    case CONSTR_NOCAF:
-        // static objects with no pointers out, so goto loop.
-
-        // It is not just enough not to visit *c; it is
-        // mandatory because CONSTR_NOCAF are not reachable from
-        // scavenged_static_objects, the list from which is assumed to traverse
-        // all static objects after major garbage collections.
-        goto loop;
-
-    case THUNK_STATIC:
-        if (get_itbl(c)->srt == 0) {
-            // No need to visit *c; no dynamic objects are reachable from it.
-            //
-            // Static objects: if we traverse all the live closures,
-            // including static closures, during each heap census then
-            // we will observe that some static closures appear and
-            // disappear.  eg. a closure may contain a pointer to a
-            // static function 'f' which is not otherwise reachable
-            // (it doesn't indirectly point to any CAFs, so it doesn't
-            // appear in any SRTs), so we would find 'f' during
-            // traversal.  However on the next sweep there may be no
-            // closures pointing to 'f'.
-            //
-            // We must therefore ignore static closures whose SRT is
-            // empty, because these are exactly the closures that may
-            // "appear".  A closure with a non-empty SRT, and which is
-            // still required, will always be reachable.
-            //
-            // But what about CONSTR?  Surely these may be able
-            // to appear, and they don't have SRTs, so we can't
-            // check.  So for now, we're calling
-            // resetStaticObjectForProfiling() from the
-            // garbage collector to reset the retainer sets in all the
-            // reachable static objects.
-            goto loop;
-        }
-        /* fall-thru */
-
-    case FUN_STATIC: {
-        const StgInfoTable *info = get_itbl(c);
-        if (info->srt == 0 && info->layout.payload.ptrs == 0) {
-            goto loop;
-        } else {
-            break;
-        }
-    }
-
-    default:
-        break;
-    }
-
-    // If this is the first visit to c, initialize its data.
-    bool first_visit = traverseMaybeInitClosureData(c);
-    bool traverse_children
-        = visit_cb(c, cp, data, first_visit, (stackData*)&child_data);
-    if(!traverse_children)
-        goto loop;
-
-    // process child
-
-    // Special case closures: we process these all in one go rather
-    // than attempting to save the current position, because doing so
-    // would be hard.
-    switch (typeOfc) {
-    case STACK:
-        traversePushStack(ts, c, child_data,
-                    ((StgStack *)c)->sp,
-                    ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
-        goto loop;
-
-    case TSO:
-    {
-        StgTSO *tso = (StgTSO *)c;
-
-        traversePushClosure(ts, (StgClosure *) tso->stackobj, c, child_data);
-        traversePushClosure(ts, (StgClosure *) tso->blocked_exceptions, c, child_data);
-        traversePushClosure(ts, (StgClosure *) tso->bq, c, child_data);
-        traversePushClosure(ts, (StgClosure *) tso->trec, c, child_data);
-        if (   tso->why_blocked == BlockedOnMVar
-               || tso->why_blocked == BlockedOnMVarRead
-               || tso->why_blocked == BlockedOnBlackHole
-               || tso->why_blocked == BlockedOnMsgThrowTo
-            ) {
-            traversePushClosure(ts, tso->block_info.closure, c, child_data);
-        }
-        goto loop;
-    }
-
-    case BLOCKING_QUEUE:
-    {
-        StgBlockingQueue *bq = (StgBlockingQueue *)c;
-        traversePushClosure(ts, (StgClosure *) bq->link,  c, child_data);
-        traversePushClosure(ts, (StgClosure *) bq->bh,    c, child_data);
-        traversePushClosure(ts, (StgClosure *) bq->owner, c, child_data);
-        goto loop;
-    }
-
-    case PAP:
-    {
-        StgPAP *pap = (StgPAP *)c;
-        traversePAP(ts, c, child_data, pap->fun, pap->payload, pap->n_args);
-        goto loop;
-    }
-
-    case AP:
-    {
-        StgAP *ap = (StgAP *)c;
-        traversePAP(ts, c, child_data, ap->fun, ap->payload, ap->n_args);
-        goto loop;
-    }
-
-    case AP_STACK:
-        traversePushClosure(ts, ((StgAP_STACK *)c)->fun, c, child_data);
-        traversePushStack(ts, c, child_data,
-                    (StgPtr)((StgAP_STACK *)c)->payload,
-                    (StgPtr)((StgAP_STACK *)c)->payload +
-                             ((StgAP_STACK *)c)->size);
-        goto loop;
-    }
-
-    traversePushChildren(ts, c, child_data, &first_child);
-
-    // If first_child is null, c has no child.
-    // If first_child is not null, the top stack element points to the next
-    // object. traversePushChildren() may or may not push a stackElement on the
-    // stack.
-    if (first_child == NULL)
-        goto loop;
-
-    // (c, cp, data) = (first_child, c, child_data)
-    data = child_data;
-    cp = c;
-    c = first_child;
-    goto inner_loop;
-}
-
 /**
  *  Push every object reachable from *tl onto the traversal work stack.
  */
@@ -1684,72 +397,6 @@ computeRetainerSet( traverseState *ts )
 }
 
 /* -----------------------------------------------------------------------------
- *  Traverse all static objects for which we compute retainer sets,
- *  and reset their rs fields to NULL, which is accomplished by
- *  invoking traverseMaybeInitClosureData(). This function must be called
- *  before zeroing all objects reachable from scavenged_static_objects
- *  in the case of major garbage collections. See GarbageCollect() in
- *  GC.c.
- *  Note:
- *    The mut_once_list of the oldest generation must also be traversed?
- *    Why? Because if the evacuation of an object pointed to by a static
- *    indirection object fails, it is put back to the mut_once_list of
- *    the oldest generation.
- *    However, this is not necessary because any static indirection objects
- *    are just traversed through to reach dynamic objects. In other words,
- *    they are not taken into consideration in computing retainer sets.
- *
- * SDM (20/7/2011): I don't think this is doing anything sensible,
- * because it happens before retainerProfile() and at the beginning of
- * retainerProfil() we change the sense of 'flip'.  So all of the
- * calls to traverseMaybeInitClosureData() here are initialising retainer sets
- * with the wrong flip.  Also, I don't see why this is necessary.  I
- * added a traverseMaybeInitClosureData() call to retainRoot(), and that seems
- * to have fixed the assertion failure in retainerSetOf() I was
- * encountering.
- * -------------------------------------------------------------------------- */
-void
-resetStaticObjectForProfiling( StgClosure *static_objects )
-{
-    uint32_t count = 0;
-    StgClosure *p;
-
-    p = static_objects;
-    while (p != END_OF_STATIC_OBJECT_LIST) {
-        p = UNTAG_STATIC_LIST_PTR(p);
-        count++;
-
-        switch (get_itbl(p)->type) {
-        case IND_STATIC:
-            // Since we do not compute the retainer set of any
-            // IND_STATIC object, we don't have to reset its retainer
-            // field.
-            p = (StgClosure*)*IND_STATIC_LINK(p);
-            break;
-        case THUNK_STATIC:
-            traverseMaybeInitClosureData(p);
-            p = (StgClosure*)*THUNK_STATIC_LINK(p);
-            break;
-        case FUN_STATIC:
-        case CONSTR:
-        case CONSTR_1_0:
-        case CONSTR_2_0:
-        case CONSTR_1_1:
-        case CONSTR_NOCAF:
-            traverseMaybeInitClosureData(p);
-            p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
-            break;
-        default:
-            barf("resetStaticObjectForProfiling: %p (%lu)",
-                 p, (unsigned long)get_itbl(p)->type);
-            break;
-        }
-    }
-
-    debug("count in scavenged_static_objects = %d\n", count);
-}
-
-/* -----------------------------------------------------------------------------
  * Perform retainer profiling.
  * N is the oldest generation being profilied, where the generations are
  * numbered starting at 0.
diff --git a/rts/TraverseHeap.c b/rts/TraverseHeap.c
new file mode 100644
index 0000000000..bf2584cef4
--- /dev/null
+++ b/rts/TraverseHeap.c
@@ -0,0 +1,1371 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001,2019
+ * Author: Sungwoo Park, Daniel Gröber
+ *
+ * Generalised profiling heap traversal.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#if defined(PROFILING)
+
+#include "PosixSource.h"
+#include "Rts.h"
+#include "sm/Storage.h"
+
+#include "TraverseHeap.h"
+
+/** Note [Profiling heap traversal visited bit]
+ *
+ * If the RTS is compiled with profiling enabled StgProfHeader can be used by
+ * profiling code to store per-heap object information.
+ *
+ * The generic heap traversal code reserves the least significant bit of the
+ * largest members of the 'trav' union to decide whether we've already visited a
+ * given closure in the current pass or not. The rest of the field is free to be
+ * used by the calling profiler.
+ *
+ * By doing things this way we implicitly assume that the LSB of the largest
+ * field in the 'trav' union is insignificant. This is true at least for the
+ * word aligned pointers which the retainer profiler currently stores there and
+ * should be maintained by new users of the 'trav' union for example by shifting
+ * the real data up by one bit.
+ *
+ * Since we don't want to have to scan the entire heap a second time just to
+ * reset the per-object visitied bit before/after the real traversal we make the
+ * interpretation of this bit dependent on the value of a global variable,
+ * 'flip'.
+ *
+ * When the 'trav' bit is equal to the value of 'flip' the closure data is
+ * valid otherwise not (see isTravDataValid). We then invert the value of 'flip'
+ * on each heap traversal (see traverseWorkStack), in effect marking all
+ * closure's data as invalid at once.
+ *
+ * There are some complications with this approach, namely: static objects and
+ * mutable data. There we do just go over all existing objects to reset the bit
+ * manually. See 'resetStaticObjectForProfiling' and 'resetMutableObjects'.
+ */
+StgWord flip = 0;
+
+#define setTravDataToZero(c) \
+  (c)->header.prof.hp.trav.lsb = flip
+
+typedef enum {
+    // Object with fixed layout. Keeps an information about that
+    // element was processed. (stackPos.next.step)
+    posTypeStep,
+    // Description of the pointers-first heap object. Keeps information
+    // about layout. (stackPos.next.ptrs)
+    posTypePtrs,
+    // Keeps SRT bitmap (stackPos.next.srt)
+    posTypeSRT,
+    // Keeps a new object that was not inspected yet. Keeps a parent
+    // element (stackPos.next.parent)
+    posTypeFresh
+} nextPosType;
+
+typedef union {
+    // fixed layout or layout specified by a field in the closure
+    StgWord step;
+
+    // layout.payload
+    struct {
+        // See StgClosureInfo in InfoTables.h
+        StgHalfWord pos;
+        StgHalfWord ptrs;
+        StgPtr payload;
+    } ptrs;
+
+    // SRT
+    struct {
+        StgClosure *srt;
+    } srt;
+} nextPos;
+
+/**
+ * Position pointer into a closure. Determines what the next element to return
+ * for a stackElement is.
+ */
+typedef struct {
+    nextPosType type;
+    nextPos next;
+} stackPos;
+
+/**
+ * An element of the traversal work-stack. Besides the closure itself this also
+ * stores it's parent and associated data.
+ *
+ * When 'info.type == posTypeFresh' a 'stackElement' represents just one
+ * closure, namely 'c' and 'cp' being it's parent. Otherwise 'info' specifies an
+ * offset into the children of 'c'. This is to support returning a closure's
+ * children one-by-one without pushing one element per child onto the stack. See
+ * traversePushChildren() and traversePop().
+ *
+ */
+typedef struct stackElement_ {
+    stackPos info;
+    StgClosure *c;
+    StgClosure *cp; // parent of 'c'. Only used when info.type == posTypeFresh.
+    stackData data;
+} stackElement;
+
+
+#if defined(DEBUG)
+unsigned int g_traversalDebugLevel = 0;
+static inline void debug(const char *s, ...)
+{
+    va_list ap;
+
+    if(g_traversalDebugLevel == 0)
+        return;
+
+    va_start(ap,s);
+    vdebugBelch(s, ap);
+    va_end(ap);
+}
+#else
+#define debug(...)
+#endif
+
+// number of blocks allocated for one stack
+#define BLOCKS_IN_STACK 1
+
+/* -----------------------------------------------------------------------------
+ * Add a new block group to the stack.
+ * Invariants:
+ *  currentStack->link == s.
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE void
+newStackBlock( traverseState *ts, bdescr *bd )
+{
+    ts->currentStack = bd;
+    ts->stackTop     = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
+    ts->stackBottom  = (stackElement *)bd->start;
+    ts->stackLimit   = (stackElement *)ts->stackTop;
+    bd->free     = (StgPtr)ts->stackLimit;
+}
+
+/* -----------------------------------------------------------------------------
+ * Return to the previous block group.
+ * Invariants:
+ *   s->link == currentStack.
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE void
+returnToOldStack( traverseState *ts, bdescr *bd )
+{
+    ts->currentStack = bd;
+    ts->stackTop = (stackElement *)bd->free;
+    ts->stackBottom = (stackElement *)bd->start;
+    ts->stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
+    bd->free = (StgPtr)ts->stackLimit;
+}
+
+/**
+ *  Initializes the traversal work-stack.
+ */
+void
+initializeTraverseStack( traverseState *ts )
+{
+    if (ts->firstStack != NULL) {
+        freeChain(ts->firstStack);
+    }
+
+    ts->firstStack = allocGroup(BLOCKS_IN_STACK);
+    ts->firstStack->link = NULL;
+    ts->firstStack->u.back = NULL;
+
+    ts->stackSize = 0;
+    ts->maxStackSize = 0;
+
+    newStackBlock(ts, ts->firstStack);
+}
+
+/**
+ * Frees all the block groups in the traversal works-stack.
+ *
+ * Invariants:
+ *   firstStack != NULL
+ */
+void
+closeTraverseStack( traverseState *ts )
+{
+    freeChain(ts->firstStack);
+    ts->firstStack = NULL;
+}
+
+int
+getTraverseStackMaxSize(traverseState *ts)
+{
+    return ts->maxStackSize;
+}
+
+/* -----------------------------------------------------------------------------
+ * Returns true if the whole stack is empty.
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE bool
+isEmptyWorkStack( traverseState *ts )
+{
+    return (ts->firstStack == ts->currentStack) && ts->stackTop == ts->stackLimit;
+}
+
+/* -----------------------------------------------------------------------------
+ * Returns size of stack
+ * -------------------------------------------------------------------------- */
+W_
+traverseWorkStackBlocks(traverseState *ts)
+{
+    bdescr* bd;
+    W_ res = 0;
+
+    for (bd = ts->firstStack; bd != NULL; bd = bd->link)
+      res += bd->blocks;
+
+    return res;
+}
+
+/* -----------------------------------------------------------------------------
+ * Initializes *info from ptrs and payload.
+ * Invariants:
+ *   payload[] begins with ptrs pointers followed by non-pointers.
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE void
+init_ptrs( stackPos *info, uint32_t ptrs, StgPtr payload )
+{
+    info->type              = posTypePtrs;
+    info->next.ptrs.pos     = 0;
+    info->next.ptrs.ptrs    = ptrs;
+    info->next.ptrs.payload = payload;
+}
+
+/* -----------------------------------------------------------------------------
+ * Find the next object from *info.
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE StgClosure *
+find_ptrs( stackPos *info )
+{
+    if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
+        return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
+    } else {
+        return NULL;
+    }
+}
+
+/* -----------------------------------------------------------------------------
+ *  Initializes *info from SRT information stored in *infoTable.
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE void
+init_srt_fun( stackPos *info, const StgFunInfoTable *infoTable )
+{
+    info->type = posTypeSRT;
+    if (infoTable->i.srt) {
+        info->next.srt.srt = (StgClosure*)GET_FUN_SRT(infoTable);
+    } else {
+        info->next.srt.srt = NULL;
+    }
+}
+
+STATIC_INLINE void
+init_srt_thunk( stackPos *info, const StgThunkInfoTable *infoTable )
+{
+    info->type = posTypeSRT;
+    if (infoTable->i.srt) {
+        info->next.srt.srt = (StgClosure*)GET_SRT(infoTable);
+    } else {
+        info->next.srt.srt = NULL;
+    }
+}
+
+/* -----------------------------------------------------------------------------
+ * Find the next object from *info.
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE StgClosure *
+find_srt( stackPos *info )
+{
+    StgClosure *c;
+    if (info->type == posTypeSRT) {
+        c = info->next.srt.srt;
+        info->next.srt.srt = NULL;
+        return c;
+    }
+
+    return NULL;
+}
+
+/**
+ * Push a set of closures, represented by a single 'stackElement', onto the
+ * traversal work-stack.
+ */
+static void
+pushStackElement(traverseState *ts, stackElement *se)
+{
+    bdescr *nbd;      // Next Block Descriptor
+    if (ts->stackTop - 1 < ts->stackBottom) {
+        debug("pushStackElement() to the next stack.\n");
+
+        // currentStack->free is updated when the active stack is switched
+        // to the next stack.
+        ts->currentStack->free = (StgPtr)ts->stackTop;
+
+        if (ts->currentStack->link == NULL) {
+            nbd = allocGroup(BLOCKS_IN_STACK);
+            nbd->link = NULL;
+            nbd->u.back = ts->currentStack;
+            ts->currentStack->link = nbd;
+        } else
+            nbd = ts->currentStack->link;
+
+        newStackBlock(ts, nbd);
+    }
+
+    // adjust stackTop (acutal push)
+    ts->stackTop--;
+    // If the size of stackElement was huge, we would better replace the
+    // following statement by either a memcpy() call or a switch statement
+    // on the type of the element. Currently, the size of stackElement is
+    // small enough (5 words) that this direct assignment seems to be enough.
+    *ts->stackTop = *se;
+
+    ts->stackSize++;
+    if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
+    ASSERT(ts->stackSize >= 0);
+    debug("stackSize = %d\n", ts->stackSize);
+}
+
+/**
+ * Push a single closure onto the traversal work-stack.
+ *
+ *  cp   - object's parent
+ *  c    - closure
+ *  data - data associated with closure.
+ */
+inline void
+traversePushClosure(traverseState *ts, StgClosure *c, StgClosure *cp, stackData data) {
+    stackElement se;
+
+    se.c = c;
+    se.cp = cp;
+    se.data = data;
+    se.info.type = posTypeFresh;
+
+    pushStackElement(ts, &se);
+};
+
+/**
+ * traversePushChildren() extracts the first child of 'c' in 'first_child' and
+ * conceptually pushes all remaining children of 'c' onto the traversal stack
+ * while associating 'data' with the pushed elements to be returned upon poping.
+ *
+ * If 'c' has no children, 'first_child' is set to NULL and nothing is pushed
+ * onto the stack.
+ *
+ * If 'c' has only one child, 'first_child' is set to that child and nothing is
+ * pushed onto the stack.
+ *
+ * Invariants:
+ *
+ *  - 'c' is not any of TSO, AP, PAP, AP_STACK, which means that there cannot
+ *       be any stack objects.
+ *
+ * Note: SRTs are considered to be children as well.
+ *
+ * Note: When pushing onto the stack we only really push one 'stackElement'
+ * representing all children onto the stack. See traversePop()
+ */
+STATIC_INLINE void
+traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosure **first_child)
+{
+    stackElement se;
+
+    debug("traversePushChildren(): stackTop = 0x%x\n", ts->stackTop);
+
+    ASSERT(get_itbl(c)->type != TSO);
+    ASSERT(get_itbl(c)->type != AP_STACK);
+
+    //
+    // fill in se
+    //
+
+    se.c = c;
+    se.data = data;
+    // Note: se.cp ommitted on purpose, only traversePushClosure uses that.
+
+    // fill in se.info
+    switch (get_itbl(c)->type) {
+        // no child, no SRT
+    case CONSTR_0_1:
+    case CONSTR_0_2:
+    case ARR_WORDS:
+    case COMPACT_NFDATA:
+        *first_child = NULL;
+        return;
+
+        // one child (fixed), no SRT
+    case MUT_VAR_CLEAN:
+    case MUT_VAR_DIRTY:
+        *first_child = ((StgMutVar *)c)->var;
+        return;
+    case THUNK_SELECTOR:
+        *first_child = ((StgSelector *)c)->selectee;
+        return;
+    case BLACKHOLE:
+        *first_child = ((StgInd *)c)->indirectee;
+        return;
+    case CONSTR_1_0:
+    case CONSTR_1_1:
+        *first_child = c->payload[0];
+        return;
+
+        // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
+        // of the next child. We do not write a separate initialization code.
+        // Also we do not have to initialize info.type;
+
+        // two children (fixed), no SRT
+        // need to push a stackElement, but nothing to store in se.info
+    case CONSTR_2_0:
+        *first_child = c->payload[0];         // return the first pointer
+        se.info.type = posTypeStep;
+        se.info.next.step = 2;            // 2 = second
+        break;
+
+        // three children (fixed), no SRT
+        // need to push a stackElement
+    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;
+        se.info.type = posTypeStep;
+        se.info.next.step = 2;            // 2 = second
+        break;
+
+        // three children (fixed), no SRT
+    case WEAK:
+        *first_child = ((StgWeak *)c)->key;
+        se.info.type = posTypeStep;
+        se.info.next.step = 2;
+        break;
+
+        // layout.payload.ptrs, no SRT
+    case TVAR:
+    case CONSTR:
+    case CONSTR_NOCAF:
+    case PRIM:
+    case MUT_PRIM:
+    case BCO:
+        init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
+                  (StgPtr)c->payload);
+        *first_child = find_ptrs(&se.info);
+        if (*first_child == NULL)
+            return;   // no child
+        break;
+
+        // StgMutArrPtr.ptrs, no SRT
+    case MUT_ARR_PTRS_CLEAN:
+    case MUT_ARR_PTRS_DIRTY:
+    case MUT_ARR_PTRS_FROZEN_CLEAN:
+    case MUT_ARR_PTRS_FROZEN_DIRTY:
+        init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
+                  (StgPtr)(((StgMutArrPtrs *)c)->payload));
+        *first_child = find_ptrs(&se.info);
+        if (*first_child == NULL)
+            return;
+        break;
+
+        // StgMutArrPtr.ptrs, no SRT
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
+    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
+        init_ptrs(&se.info, ((StgSmallMutArrPtrs *)c)->ptrs,
+                  (StgPtr)(((StgSmallMutArrPtrs *)c)->payload));
+        *first_child = find_ptrs(&se.info);
+        if (*first_child == NULL)
+            return;
+        break;
+
+    // layout.payload.ptrs, SRT
+    case FUN_STATIC:
+    case FUN:           // *c is a heap object.
+    case FUN_2_0:
+        init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
+        *first_child = find_ptrs(&se.info);
+        if (*first_child == NULL)
+            // no child from ptrs, so check SRT
+            goto fun_srt_only;
+        break;
+
+    case THUNK:
+    case THUNK_2_0:
+        init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
+                  (StgPtr)((StgThunk *)c)->payload);
+        *first_child = find_ptrs(&se.info);
+        if (*first_child == NULL)
+            // no child from ptrs, so check SRT
+            goto thunk_srt_only;
+        break;
+
+        // 1 fixed child, SRT
+    case FUN_1_0:
+    case FUN_1_1:
+        *first_child = c->payload[0];
+        ASSERT(*first_child != NULL);
+        init_srt_fun(&se.info, get_fun_itbl(c));
+        break;
+
+    case THUNK_1_0:
+    case THUNK_1_1:
+        *first_child = ((StgThunk *)c)->payload[0];
+        ASSERT(*first_child != NULL);
+        init_srt_thunk(&se.info, get_thunk_itbl(c));
+        break;
+
+    case FUN_0_1:      // *c is a heap object.
+    case FUN_0_2:
+    fun_srt_only:
+        init_srt_fun(&se.info, get_fun_itbl(c));
+        *first_child = find_srt(&se.info);
+        if (*first_child == NULL)
+            return;     // no child
+        break;
+
+    // SRT only
+    case THUNK_STATIC:
+        ASSERT(get_itbl(c)->srt != 0);
+        /* fall-thru */
+    case THUNK_0_1:
+    case THUNK_0_2:
+    thunk_srt_only:
+        init_srt_thunk(&se.info, get_thunk_itbl(c));
+        *first_child = find_srt(&se.info);
+        if (*first_child == NULL)
+            return;     // no child
+        break;
+
+    case TREC_CHUNK:
+        *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
+        se.info.type = posTypeStep;
+        se.info.next.step = 0;  // entry no.
+        break;
+
+        // cannot appear
+    case PAP:
+    case AP:
+    case AP_STACK:
+    case TSO:
+    case STACK:
+    case IND_STATIC:
+        // stack objects
+    case UPDATE_FRAME:
+    case CATCH_FRAME:
+    case UNDERFLOW_FRAME:
+    case STOP_FRAME:
+    case RET_BCO:
+    case RET_SMALL:
+    case RET_BIG:
+        // invalid objects
+    case IND:
+    case INVALID_OBJECT:
+    default:
+        barf("Invalid object *c in push(): %d", get_itbl(c)->type);
+        return;
+    }
+
+    // se.cp has to be initialized when type==posTypeFresh. We don't do that
+    // here though. So type must be !=posTypeFresh.
+    ASSERT(se.info.type != posTypeFresh);
+
+    pushStackElement(ts, &se);
+}
+
+/**
+ *  popStackElement(): Remove a depleted stackElement from the top of the
+ *  traversal work-stack.
+ *
+ *  Invariants:
+ *    stackTop cannot be equal to stackLimit unless the whole stack is
+ *    empty, in which case popStackElement() is not allowed.
+ */
+static void
+popStackElement(traverseState *ts) {
+    debug("popStackElement(): stackTop = 0x%x\n", ts->stackTop);
+
+    ASSERT(ts->stackTop != ts->stackLimit);
+    ASSERT(!isEmptyWorkStack(ts));
+
+    // <= (instead of <) is wrong!
+    if (ts->stackTop + 1 < ts->stackLimit) {
+        ts->stackTop++;
+
+        ts->stackSize--;
+        if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
+        ASSERT(ts->stackSize >= 0);
+        debug("stackSize = (--) %d\n", ts->stackSize);
+
+        return;
+    }
+
+    bdescr *pbd;    // Previous Block Descriptor
+
+    debug("popStackElement() to the previous stack.\n");
+
+    ASSERT(ts->stackTop + 1 == ts->stackLimit);
+    ASSERT(ts->stackBottom == (stackElement *)ts->currentStack->start);
+
+    if (ts->firstStack == ts->currentStack) {
+        // The stack is completely empty.
+        ts->stackTop++;
+        ASSERT(ts->stackTop == ts->stackLimit);
+
+        ts->stackSize--;
+        if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
+        ASSERT(ts->stackSize >= 0);
+        debug("stackSize = %d\n", ts->stackSize);
+
+        return;
+    }
+
+    // currentStack->free is updated when the active stack is switched back
+    // to the previous stack.
+    ts->currentStack->free = (StgPtr)ts->stackLimit;
+
+    // find the previous block descriptor
+    pbd = ts->currentStack->u.back;
+    ASSERT(pbd != NULL);
+
+    returnToOldStack(ts, pbd);
+
+    ts->stackSize--;
+    if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize;
+    ASSERT(ts->stackSize >= 0);
+    debug("stackSize = %d\n", ts->stackSize);
+}
+
+/**
+ *  Finds the next object to be considered for retainer profiling and store
+ *  its pointer to *c.
+ *
+ *  If the unprocessed object was stored in the stack (posTypeFresh), the
+ *  this object is returned as-is. Otherwise Test if the topmost stack
+ *  element indicates that more objects are left,
+ *  and if so, retrieve the first object and store its pointer to *c. Also,
+ *  set *cp and *data appropriately, both of which are stored in the stack
+ *  element.  The topmost stack element then is overwritten so as for it to now
+ *  denote the next object.
+ *
+ *  If the topmost stack element indicates no more objects are left, pop
+ *  off the stack element until either an object can be retrieved or
+ *  the work-stack becomes empty, indicated by true returned by
+ *  isEmptyWorkStack(), in which case *c is set to NULL.
+ *
+ *  Note:
+ *
+ *    It is okay to call this function even when the work-stack is empty.
+ */
+STATIC_INLINE void
+traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data)
+{
+    stackElement *se;
+
+    debug("traversePop(): stackTop = 0x%x\n", ts->stackTop);
+
+    // Is this the last internal element? If so instead of modifying the current
+    // stackElement in place we actually remove it from the stack.
+    bool last = false;
+
+    do {
+        if (isEmptyWorkStack(ts)) {
+            *c = NULL;
+            return;
+        }
+
+        // Note: Below every `break`, where the loop condition is true, must be
+        // accompanied by a popStackElement() otherwise this is an infinite
+        // loop.
+        se = ts->stackTop;
+
+        // If this is a top-level element, you should pop that out.
+        if (se->info.type == posTypeFresh) {
+            *cp = se->cp;
+            *c = se->c;
+            *data = se->data;
+            popStackElement(ts);
+            return;
+        }
+
+        // Note: The first ptr of all of these was already returned as
+        // *fist_child in push(), so we always start with the second field.
+        switch (get_itbl(se->c)->type) {
+            // two children (fixed), no SRT
+            // nothing in se.info
+        case CONSTR_2_0:
+            *c = se->c->payload[1];
+            last = true;
+            goto out;
+
+            // three children (fixed), no SRT
+            // need to push a stackElement
+        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
+                // no popStackElement
+            } else {
+                *c = ((StgMVar *)se->c)->value;
+                last = true;
+            }
+            goto out;
+
+            // three children (fixed), no SRT
+        case WEAK:
+            if (se->info.next.step == 2) {
+                *c = ((StgWeak *)se->c)->value;
+                se->info.next.step++;
+                // no popStackElement
+            } else {
+                *c = ((StgWeak *)se->c)->finalizer;
+                last = true;
+            }
+            goto out;
+
+        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;
+            uint32_t entry_no = se->info.next.step >> 2;
+            uint32_t field_no = se->info.next.step & 3;
+            if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
+                *c = NULL;
+                popStackElement(ts);
+                break; // this breaks out of the switch not the loop
+            }
+            entry = &((StgTRecChunk *)se->c)->entries[entry_no];
+            if (field_no == 0) {
+                *c = (StgClosure *)entry->tvar;
+            } else if (field_no == 1) {
+                *c = entry->expected_value;
+            } else {
+                *c = entry->new_value;
+            }
+            se->info.next.step++;
+            goto out;
+        }
+
+        case TVAR:
+        case CONSTR:
+        case PRIM:
+        case MUT_PRIM:
+        case BCO:
+            // StgMutArrPtr.ptrs, no SRT
+        case MUT_ARR_PTRS_CLEAN:
+        case MUT_ARR_PTRS_DIRTY:
+        case MUT_ARR_PTRS_FROZEN_CLEAN:
+        case MUT_ARR_PTRS_FROZEN_DIRTY:
+        case SMALL_MUT_ARR_PTRS_CLEAN:
+        case SMALL_MUT_ARR_PTRS_DIRTY:
+        case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
+        case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
+            *c = find_ptrs(&se->info);
+            if (*c == NULL) {
+                popStackElement(ts);
+                break; // this breaks out of the switch not the loop
+            }
+            goto out;
+
+            // layout.payload.ptrs, SRT
+        case FUN:         // always a heap object
+        case FUN_STATIC:
+        case FUN_2_0:
+            if (se->info.type == posTypePtrs) {
+                *c = find_ptrs(&se->info);
+                if (*c != NULL) {
+                    goto out;
+                }
+                init_srt_fun(&se->info, get_fun_itbl(se->c));
+            }
+            goto do_srt;
+
+        case THUNK:
+        case THUNK_2_0:
+            if (se->info.type == posTypePtrs) {
+                *c = find_ptrs(&se->info);
+                if (*c != NULL) {
+                    goto out;
+                }
+                init_srt_thunk(&se->info, get_thunk_itbl(se->c));
+            }
+            goto do_srt;
+
+            // SRT
+        do_srt:
+        case THUNK_STATIC:
+        case FUN_0_1:
+        case FUN_0_2:
+        case THUNK_0_1:
+        case THUNK_0_2:
+        case FUN_1_0:
+        case FUN_1_1:
+        case THUNK_1_0:
+        case THUNK_1_1:
+            *c = find_srt(&se->info);
+            if(*c == NULL) {
+                popStackElement(ts);
+                break; // this breaks out of the switch not the loop
+            }
+            goto out;
+
+            // no child (fixed), no SRT
+        case CONSTR_0_1:
+        case CONSTR_0_2:
+        case ARR_WORDS:
+            // one child (fixed), no SRT
+        case MUT_VAR_CLEAN:
+        case MUT_VAR_DIRTY:
+        case THUNK_SELECTOR:
+        case CONSTR_1_1:
+            // cannot appear
+        case PAP:
+        case AP:
+        case AP_STACK:
+        case TSO:
+        case STACK:
+        case IND_STATIC:
+        case CONSTR_NOCAF:
+            // stack objects
+        case UPDATE_FRAME:
+        case CATCH_FRAME:
+        case UNDERFLOW_FRAME:
+        case STOP_FRAME:
+        case RET_BCO:
+        case RET_SMALL:
+        case RET_BIG:
+            // invalid objects
+        case IND:
+        case INVALID_OBJECT:
+        default:
+            barf("Invalid object *c in traversePop(): %d", get_itbl(se->c)->type);
+            return;
+        }
+    } while (*c == NULL);
+
+out:
+
+    ASSERT(*c != NULL);
+
+    *cp = se->c;
+    *data = se->data;
+
+    if(last)
+        popStackElement(ts);
+
+    return;
+
+}
+
+/**
+ * Make sure a closure's profiling data is initialized to zero if it does not
+ * conform to the current value of the flip bit, returns true in this case.
+ *
+ * See Note [Profiling heap traversal visited bit].
+ */
+bool
+traverseMaybeInitClosureData(StgClosure *c)
+{
+    if (!isTravDataValid(c)) {
+        setTravDataToZero(c);
+        return true;
+    }
+    return false;
+}
+
+/* -----------------------------------------------------------------------------
+   Call traversePushClosure for each of the closures covered by a large bitmap.
+   -------------------------------------------------------------------------- */
+
+static void
+traverseLargeBitmap (traverseState *ts, StgPtr p, StgLargeBitmap *large_bitmap,
+                     uint32_t size, StgClosure *c, stackData data)
+{
+    uint32_t i, b;
+    StgWord bitmap;
+
+    b = 0;
+    bitmap = large_bitmap->bitmap[b];
+    for (i = 0; i < size; ) {
+        if ((bitmap & 1) == 0) {
+            traversePushClosure(ts, (StgClosure *)*p, c, data);
+        }
+        i++;
+        p++;
+        if (i % BITS_IN(W_) == 0) {
+            b++;
+            bitmap = large_bitmap->bitmap[b];
+        } else {
+            bitmap = bitmap >> 1;
+        }
+    }
+}
+
+STATIC_INLINE StgPtr
+traverseSmallBitmap (traverseState *ts, StgPtr p, uint32_t size, StgWord bitmap,
+                     StgClosure *c, stackData data)
+{
+    while (size > 0) {
+        if ((bitmap & 1) == 0) {
+            traversePushClosure(ts, (StgClosure *)*p, c, data);
+        }
+        p++;
+        bitmap = bitmap >> 1;
+        size--;
+    }
+    return p;
+}
+
+/**
+ *  traversePushStack(ts, cp, data, stackStart, stackEnd) pushes all the objects
+ *  in the STG stack-chunk from stackStart to stackEnd onto the traversal
+ *  work-stack with 'c' and 'data' being their parent and associated data,
+ *  respectively.
+ *
+ *  Invariants:
+ *
+ *    *cp is one of the following: TSO, AP_STACK.
+ *
+ *    stackStart < stackEnd.
+ *
+ *    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,
+ *    traversePushClosure() is invoked instead of evacuate().
+ */
+static void
+traversePushStack(traverseState *ts, StgClosure *cp, stackData data,
+                  StgPtr stackStart, StgPtr stackEnd)
+{
+    StgPtr p;
+    const StgRetInfoTable *info;
+    StgWord bitmap;
+    uint32_t size;
+
+    ASSERT(get_itbl(cp)->type == STACK);
+
+    p = stackStart;
+    while (p < stackEnd) {
+        info = get_ret_itbl((StgClosure *)p);
+
+        switch(info->i.type) {
+
+        case UPDATE_FRAME:
+            traversePushClosure(ts, ((StgUpdateFrame *)p)->updatee, cp, data);
+            p += sizeofW(StgUpdateFrame);
+            continue;
+
+        case UNDERFLOW_FRAME:
+        case STOP_FRAME:
+        case CATCH_FRAME:
+        case CATCH_STM_FRAME:
+        case CATCH_RETRY_FRAME:
+        case ATOMICALLY_FRAME:
+        case RET_SMALL:
+            bitmap = BITMAP_BITS(info->i.layout.bitmap);
+            size   = BITMAP_SIZE(info->i.layout.bitmap);
+            p++;
+            p = traverseSmallBitmap(ts, p, size, bitmap, cp, data);
+
+        follow_srt:
+            if (info->i.srt) {
+                traversePushClosure(ts, GET_SRT(info), cp, data);
+            }
+            continue;
+
+        case RET_BCO: {
+            StgBCO *bco;
+
+            p++;
+            traversePushClosure(ts, (StgClosure*)*p, cp, data);
+            bco = (StgBCO *)*p;
+            p++;
+            size = BCO_BITMAP_SIZE(bco);
+            traverseLargeBitmap(ts, p, BCO_BITMAP(bco), size, cp, data);
+            p += size;
+            continue;
+        }
+
+            // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
+        case RET_BIG:
+            size = GET_LARGE_BITMAP(&info->i)->size;
+            p++;
+            traverseLargeBitmap(ts, p, GET_LARGE_BITMAP(&info->i),
+                                size, cp, data);
+            p += size;
+            // and don't forget to follow the SRT
+            goto follow_srt;
+
+        case RET_FUN: {
+            StgRetFun *ret_fun = (StgRetFun *)p;
+            const StgFunInfoTable *fun_info;
+
+            traversePushClosure(ts, ret_fun->fun, cp, data);
+            fun_info = get_fun_itbl(UNTAG_CONST_CLOSURE(ret_fun->fun));
+
+            p = (P_)&ret_fun->payload;
+            switch (fun_info->f.fun_type) {
+            case ARG_GEN:
+                bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
+                size = BITMAP_SIZE(fun_info->f.b.bitmap);
+                p = traverseSmallBitmap(ts, p, size, bitmap, cp, data);
+                break;
+            case ARG_GEN_BIG:
+                size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+                traverseLargeBitmap(ts, p, GET_FUN_LARGE_BITMAP(fun_info),
+                                    size, cp, data);
+                p += size;
+                break;
+            default:
+                bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+                size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+                p = traverseSmallBitmap(ts, p, size, bitmap, cp, data);
+                break;
+            }
+            goto follow_srt;
+        }
+
+        default:
+            barf("Invalid object found in traversePushStack(): %d",
+                 (int)(info->i.type));
+        }
+    }
+}
+
+/* ----------------------------------------------------------------------------
+ * Call traversePushClosure for each of the children of a PAP/AP
+ * ------------------------------------------------------------------------- */
+
+STATIC_INLINE StgPtr
+traversePAP (traverseState *ts,
+                    StgClosure *pap,    /* NOT tagged */
+                    stackData data,
+                    StgClosure *fun,    /* tagged */
+                    StgClosure** payload, StgWord n_args)
+{
+    StgPtr p;
+    StgWord bitmap;
+    const StgFunInfoTable *fun_info;
+
+    traversePushClosure(ts, fun, pap, data);
+    fun = UNTAG_CLOSURE(fun);
+    fun_info = get_fun_itbl(fun);
+    ASSERT(fun_info->i.type != PAP);
+
+    p = (StgPtr)payload;
+
+    switch (fun_info->f.fun_type) {
+    case ARG_GEN:
+        bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
+        p = traverseSmallBitmap(ts, p, n_args, bitmap,
+                                pap, data);
+        break;
+    case ARG_GEN_BIG:
+        traverseLargeBitmap(ts, p, GET_FUN_LARGE_BITMAP(fun_info),
+                            n_args, pap, data);
+        p += n_args;
+        break;
+    case ARG_BCO:
+        traverseLargeBitmap(ts, (StgPtr)payload, BCO_BITMAP(fun),
+                            n_args, pap, data);
+        p += n_args;
+        break;
+    default:
+        bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+        p = traverseSmallBitmap(ts, p, n_args, bitmap, pap, data);
+        break;
+    }
+    return p;
+}
+
+static void
+resetMutableObjects(void)
+{
+    uint32_t g, n;
+    bdescr *bd;
+    StgPtr ml;
+
+    // The following code resets the 'trav' field of each unvisited mutable
+    // object.
+    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+        // NOT true: even G0 has a block on its mutable list
+        // ASSERT(g != 0 || (generations[g].mut_list == NULL));
+
+        // Traversing through mut_list is necessary
+        // because we can find MUT_VAR objects which have not been
+        // visited during heap traversal.
+        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++) {
+
+                traverseMaybeInitClosureData((StgClosure *)*ml);
+            }
+          }
+        }
+    }
+}
+
+/**
+ * Traverse all closures on the traversal work-stack, calling 'visit_cb' on each
+ * closure. See 'visitClosure_cb' for details. This function flips the 'flip'
+ * bit and hence every closure's profiling data will be reset to zero upon
+ * visiting. See Note [Profiling heap traversal visited bit].
+ */
+void
+traverseWorkStack(traverseState *ts, visitClosure_cb visit_cb)
+{
+    // first_child = first child of c
+    StgClosure *c, *cp, *first_child;
+    stackData data, child_data;
+    StgWord typeOfc;
+
+    // Now we flip the flip bit.
+    flip = flip ^ 1;
+
+    // c = Current closure                           (possibly tagged)
+    // cp = Current closure's Parent                 (NOT tagged)
+    // data = current closures' associated data      (NOT tagged)
+    // data_out = data to associate with current closure's children
+
+loop:
+    traversePop(ts, &c, &cp, &data);
+
+    if (c == NULL) {
+        debug("maxStackSize= %d\n", ts->maxStackSize);
+        resetMutableObjects();
+        return;
+    }
+inner_loop:
+    c = UNTAG_CLOSURE(c);
+
+    typeOfc = get_itbl(c)->type;
+
+    // special cases
+    switch (typeOfc) {
+    case TSO:
+        if (((StgTSO *)c)->what_next == ThreadComplete ||
+            ((StgTSO *)c)->what_next == ThreadKilled) {
+            debug("ThreadComplete or ThreadKilled encountered in traverseWorkStack()\n");
+            goto loop;
+        }
+        break;
+
+    case IND_STATIC:
+        // We just skip IND_STATIC, so it's never visited.
+        c = ((StgIndStatic *)c)->indirectee;
+        goto inner_loop;
+
+    case CONSTR_NOCAF:
+        // static objects with no pointers out, so goto loop.
+
+        // It is not just enough not to visit *c; it is
+        // mandatory because CONSTR_NOCAF are not reachable from
+        // scavenged_static_objects, the list from which is assumed to traverse
+        // all static objects after major garbage collections.
+        goto loop;
+
+    case THUNK_STATIC:
+        if (get_itbl(c)->srt == 0) {
+            // No need to visit *c; no dynamic objects are reachable from it.
+            //
+            // Static objects: if we traverse all the live closures,
+            // including static closures, during each heap census then
+            // we will observe that some static closures appear and
+            // disappear.  eg. a closure may contain a pointer to a
+            // static function 'f' which is not otherwise reachable
+            // (it doesn't indirectly point to any CAFs, so it doesn't
+            // appear in any SRTs), so we would find 'f' during
+            // traversal.  However on the next sweep there may be no
+            // closures pointing to 'f'.
+            //
+            // We must therefore ignore static closures whose SRT is
+            // empty, because these are exactly the closures that may
+            // "appear".  A closure with a non-empty SRT, and which is
+            // still required, will always be reachable.
+            //
+            // But what about CONSTR?  Surely these may be able
+            // to appear, and they don't have SRTs, so we can't
+            // check.  So for now, we're calling
+            // resetStaticObjectForProfiling() from the
+            // garbage collector to reset the retainer sets in all the
+            // reachable static objects.
+            goto loop;
+        }
+        /* fall-thru */
+
+    case FUN_STATIC: {
+        const StgInfoTable *info = get_itbl(c);
+        if (info->srt == 0 && info->layout.payload.ptrs == 0) {
+            goto loop;
+        } else {
+            break;
+        }
+    }
+
+    default:
+        break;
+    }
+
+    // If this is the first visit to c, initialize its data.
+    bool first_visit = traverseMaybeInitClosureData(c);
+    bool traverse_children
+        = visit_cb(c, cp, data, first_visit, (stackData*)&child_data);
+    if(!traverse_children)
+        goto loop;
+
+    // process child
+
+    // Special case closures: we process these all in one go rather
+    // than attempting to save the current position, because doing so
+    // would be hard.
+    switch (typeOfc) {
+    case STACK:
+        traversePushStack(ts, c, child_data,
+                    ((StgStack *)c)->sp,
+                    ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
+        goto loop;
+
+    case TSO:
+    {
+        StgTSO *tso = (StgTSO *)c;
+
+        traversePushClosure(ts, (StgClosure *) tso->stackobj, c, child_data);
+        traversePushClosure(ts, (StgClosure *) tso->blocked_exceptions, c, child_data);
+        traversePushClosure(ts, (StgClosure *) tso->bq, c, child_data);
+        traversePushClosure(ts, (StgClosure *) tso->trec, c, child_data);
+        if (   tso->why_blocked == BlockedOnMVar
+               || tso->why_blocked == BlockedOnMVarRead
+               || tso->why_blocked == BlockedOnBlackHole
+               || tso->why_blocked == BlockedOnMsgThrowTo
+            ) {
+            traversePushClosure(ts, tso->block_info.closure, c, child_data);
+        }
+        goto loop;
+    }
+
+    case BLOCKING_QUEUE:
+    {
+        StgBlockingQueue *bq = (StgBlockingQueue *)c;
+        traversePushClosure(ts, (StgClosure *) bq->link,  c, child_data);
+        traversePushClosure(ts, (StgClosure *) bq->bh,    c, child_data);
+        traversePushClosure(ts, (StgClosure *) bq->owner, c, child_data);
+        goto loop;
+    }
+
+    case PAP:
+    {
+        StgPAP *pap = (StgPAP *)c;
+        traversePAP(ts, c, child_data, pap->fun, pap->payload, pap->n_args);
+        goto loop;
+    }
+
+    case AP:
+    {
+        StgAP *ap = (StgAP *)c;
+        traversePAP(ts, c, child_data, ap->fun, ap->payload, ap->n_args);
+        goto loop;
+    }
+
+    case AP_STACK:
+        traversePushClosure(ts, ((StgAP_STACK *)c)->fun, c, child_data);
+        traversePushStack(ts, c, child_data,
+                    (StgPtr)((StgAP_STACK *)c)->payload,
+                    (StgPtr)((StgAP_STACK *)c)->payload +
+                             ((StgAP_STACK *)c)->size);
+        goto loop;
+    }
+
+    traversePushChildren(ts, c, child_data, &first_child);
+
+    // If first_child is null, c has no child.
+    // If first_child is not null, the top stack element points to the next
+    // object. traversePushChildren() may or may not push a stackElement on the
+    // stack.
+    if (first_child == NULL)
+        goto loop;
+
+    // (c, cp, data) = (first_child, c, child_data)
+    data = child_data;
+    cp = c;
+    c = first_child;
+    goto inner_loop;
+}
+
+/* -----------------------------------------------------------------------------
+ *  Traverse all static objects for which we compute retainer sets,
+ *  and reset their rs fields to NULL, which is accomplished by
+ *  invoking traverseMaybeInitClosureData(). This function must be called
+ *  before zeroing all objects reachable from scavenged_static_objects
+ *  in the case of major garbage collections. See GarbageCollect() in
+ *  GC.c.
+ *  Note:
+ *    The mut_once_list of the oldest generation must also be traversed?
+ *    Why? Because if the evacuation of an object pointed to by a static
+ *    indirection object fails, it is put back to the mut_once_list of
+ *    the oldest generation.
+ *    However, this is not necessary because any static indirection objects
+ *    are just traversed through to reach dynamic objects. In other words,
+ *    they are not taken into consideration in computing retainer sets.
+ *
+ * SDM (20/7/2011): I don't think this is doing anything sensible,
+ * because it happens before retainerProfile() and at the beginning of
+ * retainerProfil() we change the sense of 'flip'.  So all of the
+ * calls to traverseMaybeInitClosureData() here are initialising retainer sets
+ * with the wrong flip.  Also, I don't see why this is necessary.  I
+ * added a traverseMaybeInitClosureData() call to retainRoot(), and that seems
+ * to have fixed the assertion failure in retainerSetOf() I was
+ * encountering.
+ * -------------------------------------------------------------------------- */
+void
+resetStaticObjectForProfiling( StgClosure *static_objects )
+{
+    uint32_t count = 0;
+    StgClosure *p;
+
+    p = static_objects;
+    while (p != END_OF_STATIC_OBJECT_LIST) {
+        p = UNTAG_STATIC_LIST_PTR(p);
+        count++;
+
+        switch (get_itbl(p)->type) {
+        case IND_STATIC:
+            // Since we do not compute the retainer set of any
+            // IND_STATIC object, we don't have to reset its retainer
+            // field.
+            p = (StgClosure*)*IND_STATIC_LINK(p);
+            break;
+        case THUNK_STATIC:
+            traverseMaybeInitClosureData(p);
+            p = (StgClosure*)*THUNK_STATIC_LINK(p);
+            break;
+        case FUN_STATIC:
+        case CONSTR:
+        case CONSTR_1_0:
+        case CONSTR_2_0:
+        case CONSTR_1_1:
+        case CONSTR_NOCAF:
+            traverseMaybeInitClosureData(p);
+            p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
+            break;
+        default:
+            barf("resetStaticObjectForProfiling: %p (%lu)",
+                 p, (unsigned long)get_itbl(p)->type);
+            break;
+        }
+    }
+
+    debug("count in scavenged_static_objects = %d\n", count);
+}
+
+#endif /* PROFILING */
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index 7ce3c7f5aa..674566c0ad 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -430,6 +430,7 @@ library
                Timer.c
                TopHandler.c
                Trace.c
+               TraverseHeap.c
                WSDeque.c
                Weak.c
                eventlog/EventLog.c