X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FRetainerProfile.c;h=916ce9090db264eff143dd07283953a26f1cb05f;hb=c1d0aa931d8468c5fc02f069f2a5f32b057f139c;hp=f811d73aab4c6b03bedca3e80093aaa07e5b79b8;hpb=db61851c5472bf565cd1da900b33d6e033fd743d;p=ghc-hetmet.git

diff --git a/ghc/rts/RetainerProfile.c b/ghc/rts/RetainerProfile.c
index f811d73..916ce90 100644
--- a/ghc/rts/RetainerProfile.c
+++ b/ghc/rts/RetainerProfile.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RetainerProfile.c,v 1.1 2001/11/22 14:25:12 simonmar Exp $
+ * $Id: RetainerProfile.c,v 1.7 2003/02/22 04:51:52 sof Exp $
  *
  * (c) The GHC Team, 2001
  * Author: Sungwoo Park
@@ -10,6 +10,8 @@
 
 #ifdef PROFILING
 
+#include <stdio.h>
+
 #include "Rts.h"
 #include "RtsUtils.h"
 #include "RetainerProfile.h"
@@ -21,12 +23,12 @@
 #include "RtsFlags.h"
 #include "Weak.h"
 #include "Sanity.h"
+#include "StablePriv.h"
 #include "Profiling.h"
 #include "Stats.h"
 #include "BlockAlloc.h"
-#include "Itimer.h"
-#include "Proftimer.h"
 #include "ProfHeap.h"
+#include "Apply.h"
 
 /*
   Note: what to change in order to plug-in a new retainer profiling scheme?
@@ -54,20 +56,14 @@ static nat timesAnyObjectVisited; // number of times any objects are visited
   pointer. See retainerSetOf().
  */
 
-// extract the retainer set field from c
-#define RSET(c)   ((c)->header.prof.hp.rs)
-
-static StgWord flip = 0;     // flip bit
+StgWord flip = 0;     // flip bit
                       // must be 0 if DEBUG_RETAINER is on (for static closures)
 
-#define isRetainerSetFieldValid(c) \
-  ((((StgWord)(c)->header.prof.hp.rs & 1) ^ flip) == 0)
-
 #define setRetainerSetToNull(c)   \
   (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
 
-static void retainStack(StgClosure *, StgClosure *, StgClosure *, StgPtr, StgPtr);
-static void retainClosure(StgClosure *, StgClosure *, StgClosure *);
+static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
+static void retainClosure(StgClosure *, StgClosure *, retainer);
 #ifdef DEBUG_RETAINER
 static void belongToHeap(StgPtr p);
 #endif
@@ -141,7 +137,7 @@ typedef struct {
 
 typedef struct {
     StgClosure *c;
-    StgClosure *c_child_r;
+    retainer c_child_r;
     stackPos info;
 } stackElement;
 
@@ -302,11 +298,19 @@ find_ptrs( stackPos *info )
  *  Initializes *info from SRT information stored in *infoTable.
  * -------------------------------------------------------------------------- */
 static inline void
-init_srt( stackPos *info, StgInfoTable *infoTable )
+init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
+{
+    info->type = posTypeSRT;
+    info->next.srt.srt = (StgClosure **)(infoTable->srt);
+    info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
+}
+
+static inline void
+init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
 {
     info->type = posTypeSRT;
     info->next.srt.srt = (StgClosure **)(infoTable->srt);
-    info->next.srt.srt_end = info->next.srt.srt + infoTable->srt_len;
+    info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
 }
 
 /* -----------------------------------------------------------------------------
@@ -345,12 +349,12 @@ find_srt( stackPos *info )
 
  *  Invariants:
  *     *c_child_r is the most recent retainer of *c's children.
- *     *c is not any of TSO, PAP, or AP_UPD, which means that
+ *     *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.
  * -------------------------------------------------------------------------- */
 static inline void
-push( StgClosure *c, StgClosure *c_child_r, StgClosure **first_child )
+push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 {
     stackElement se;
     bdescr *nbd;      // Next Block Descriptor
@@ -360,8 +364,7 @@ push( StgClosure *c, StgClosure *c_child_r, StgClosure **first_child )
 #endif
 
     ASSERT(get_itbl(c)->type != TSO);
-    ASSERT(get_itbl(c)->type != PAP);
-    ASSERT(get_itbl(c)->type != AP_UPD);
+    ASSERT(get_itbl(c)->type != AP_STACK);
 
     //
     // fill in se
@@ -461,35 +464,55 @@ push( StgClosure *c, StgClosure *c_child_r, StgClosure **first_child )
     // layout.payload.ptrs, SRT
     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)c->payload);
 	*first_child = find_ptrs(&se.info);
 	if (*first_child == NULL)
 	    // no child from ptrs, so check SRT
-	    goto srt_only;
+	    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 = c->payload[0];
 	ASSERT(*first_child != NULL);
-	init_srt(&se.info, get_itbl(c));
+	init_srt_thunk(&se.info, get_thunk_itbl(c));
 	break;
 
-    // SRT only
-    case THUNK_STATIC:
     case FUN_STATIC:      // *c is a heap object.
 	ASSERT(get_itbl(c)->srt_len != 0);
     case FUN_0_1:
     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_len != 0);
     case THUNK_0_1:
     case THUNK_0_2:
-    srt_only:
-        init_srt(&se.info, get_itbl(c));
+    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
@@ -497,7 +520,8 @@ push( StgClosure *c, StgClosure *c_child_r, StgClosure **first_child )
 
 	// cannot appear
     case PAP:
-    case AP_UPD:
+    case AP:
+    case AP_STACK:
     case TSO:
     case IND_STATIC:
     case CONSTR_INTLIKE:
@@ -507,7 +531,6 @@ push( StgClosure *c, StgClosure *c_child_r, StgClosure **first_child )
     case UPDATE_FRAME:
     case CATCH_FRAME:
     case STOP_FRAME:
-    case SEQ_FRAME:
     case RET_DYN:
     case RET_BCO:
     case RET_SMALL:
@@ -666,7 +689,7 @@ popOff(void) {
  *    is empty.
  * -------------------------------------------------------------------------- */
 static inline void
-pop( StgClosure **c, StgClosure **cp, StgClosure **r )
+pop( StgClosure **c, StgClosure **cp, retainer *r )
 {
     stackElement *se;
 
@@ -741,6 +764,17 @@ pop( StgClosure **c, StgClosure **cp, StgClosure **r )
 	    // layout.payload.ptrs, SRT
 	case FUN:         // always a heap object
 	case FUN_2_0:
+	    if (se->info.type == posTypePtrs) {
+		*c = find_ptrs(&se->info);
+		if (*c != NULL) {
+		    *cp = se->c;
+		    *r = se->c_child_r;
+		    return;
+		}
+		init_srt_fun(&se->info, get_fun_itbl(se->c));
+	    }
+	    goto do_srt;
+
 	case THUNK:
 	case THUNK_2_0:
 	    if (se->info.type == posTypePtrs) {
@@ -750,11 +784,12 @@ pop( StgClosure **c, StgClosure **cp, StgClosure **r )
 		    *r = se->c_child_r;
 		    return;
 		}
-		init_srt(&se->info, get_itbl(se->c));
+		init_srt_thunk(&se->info, get_thunk_itbl(se->c));
 	    }
-	    // fall through
+	    goto do_srt;
 
 	    // SRT
+	do_srt:
 	case THUNK_STATIC:
 	case FUN_STATIC:
 	case FUN_0_1:
@@ -793,7 +828,8 @@ pop( StgClosure **c, StgClosure **cp, StgClosure **r )
 	case CONSTR_1_1:
 	    // cannot appear
 	case PAP:
-	case AP_UPD:
+	case AP:
+	case AP_STACK:
 	case TSO:
 	case IND_STATIC:
 	case CONSTR_INTLIKE:
@@ -804,7 +840,6 @@ pop( StgClosure **c, StgClosure **cp, StgClosure **r )
 	case UPDATE_FRAME:
 	case CATCH_FRAME:
 	case STOP_FRAME:
-	case SEQ_FRAME:
 	case RET_BCO:
 	case RET_SMALL:
 	case RET_VEC_SMALL:
@@ -870,167 +905,12 @@ maybeInitRetainerSet( StgClosure *c )
     }
 }
 
-static inline RetainerSet *
-retainerSetOf( StgClosure *c )
-{
-    ASSERT( isRetainerSetFieldValid(c) );
-    // StgWord has the same size as pointers, so the following type
-    // casting is okay.
-    return (RetainerSet *)((StgWord)RSET(c) ^ flip);
-}
-
-/* -----------------------------------------------------------------------------
- *  Returns the cost of the closure *c, e.g., the amount of heap memory
- *  allocated to *c. Static objects cost 0.
- *  The cost includes even the words allocated for profiling purpose.
- *  Cf. costPure().
- * -------------------------------------------------------------------------- */
-static inline nat
-cost( StgClosure *c )
-{
-    StgInfoTable *info;
-
-    info = get_itbl(c);
-    switch (info->type) {
-    case TSO:
-	return tso_sizeW((StgTSO *)c);
-
-    case THUNK:
-    case THUNK_1_0:
-    case THUNK_0_1:
-    case THUNK_2_0:
-    case THUNK_1_1:
-    case THUNK_0_2:
-	return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
-
-	// static objects
-    case CONSTR_STATIC:
-    case FUN_STATIC:
-    case THUNK_STATIC:
-	return 0;
-
-    case MVAR:
-	return sizeofW(StgMVar);
-
-    case MUT_ARR_PTRS:
-    case MUT_ARR_PTRS_FROZEN:
-	return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
-
-    case AP_UPD:
-    case PAP:
-	return pap_sizeW((StgPAP *)c);
-
-    case ARR_WORDS:
-	return arr_words_sizeW((StgArrWords *)c);
-
-    case CONSTR:
-    case CONSTR_1_0:
-    case CONSTR_0_1:
-    case CONSTR_2_0:
-    case CONSTR_1_1:
-    case CONSTR_0_2:
-    case FUN:
-    case FUN_1_0:
-    case FUN_0_1:
-    case FUN_2_0:
-    case FUN_1_1:
-    case FUN_0_2:
-    case WEAK:
-    case MUT_VAR:
-    case MUT_CONS:
-    case CAF_BLACKHOLE:
-    case BLACKHOLE:
-    case SE_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
-    case BLACKHOLE_BQ:
-    case IND_PERM:
-    case IND_OLDGEN:
-    case IND_OLDGEN_PERM:
-    case FOREIGN:
-    case BCO:
-    case STABLE_NAME:
-	return sizeW_fromITBL(info);
-
-    case THUNK_SELECTOR:
-	return sizeofW(StgHeader) + MIN_UPD_SIZE;
-
-	/*
-	  Error case
-	*/
-	// IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
-    case IND_STATIC:
-	// CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
-	// cannot be *c, *cp, *r in the retainer profiling loop.
-    case CONSTR_INTLIKE:
-    case CONSTR_CHARLIKE:
-    case CONSTR_NOCAF_STATIC:
-	// Stack objects are invalid because they are never treated as
-	// legal objects during retainer profiling.
-    case UPDATE_FRAME:
-    case CATCH_FRAME:
-    case STOP_FRAME:
-    case SEQ_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 cost(): %d", get_itbl(c)->type);
-    }
-}
-
-/* -----------------------------------------------------------------------------
- *  Returns the pure cost of the closure *c, i.e., the size of memory
- *  allocated for this object without profiling.
- *  Note & Todo:
- *    costPure() subtracts the overhead incurred by profiling for all types
- *    of objects except TSO. Even though the overhead in the TSO object
- *    itself is taken into account, the additional costs due to larger
- *    stack objects (with unnecessary retainer profiling fields) is not
- *    considered. Still, costPure() should result in an accurate estimate
- *    of heap use because stacks in TSO objects are allocated in large blocks.
- *    If we get rid of the (currently unused) retainer profiling field in
- *    all stack objects, the result will be accurate.
- * ------------------------------------------------------------------------- */
-static inline nat
-costPure( StgClosure *c )
-{
-    nat cst;
-
-    if (!closureSatisfiesConstraints(c)) {
-	return 0;
-    }
-
-    cst = cost(c);
-
-    ASSERT(cst == 0 || cst - sizeofW(StgProfHeader) > 0);
-
-    if (cst > 0) {
-	return cst - sizeofW(StgProfHeader);
-    } else {
-	return 0;
-    }
-}
-
 /* -----------------------------------------------------------------------------
  * Returns rtsTrue if *c is a retainer.
  * -------------------------------------------------------------------------- */
 static inline rtsBool
 isRetainer( StgClosure *c )
 {
-    if (get_itbl(c)->prof.closure_desc != NULL && !strcmp(get_itbl(c)->prof.closure_desc,"PCS")) { return rtsTrue; }
-
     switch (get_itbl(c)->type) {
 	//
 	//  True case
@@ -1053,7 +933,8 @@ isRetainer( StgClosure *c )
     case THUNK_1_1:
     case THUNK_0_2:
     case THUNK_SELECTOR:
-    case AP_UPD:
+    case AP:
+    case AP_STACK:
 
 	// Static thunks, or CAFS, are obviously retainers.
     case THUNK_STATIC:
@@ -1118,7 +999,6 @@ isRetainer( StgClosure *c )
     case UPDATE_FRAME:
     case CATCH_FRAME:
     case STOP_FRAME:
-    case SEQ_FRAME:
     case RET_DYN:
     case RET_BCO:
     case RET_SMALL:
@@ -1149,7 +1029,7 @@ isRetainer( StgClosure *c )
  *    Depending on the definition of this function, the maintenance of retainer
  *    sets can be made easier. If most retainer sets are likely to be created
  *    again across garbage collections, refreshAllRetainerSet() in
- *    RetainerSet.c can simply set the cost field of each retainer set.
+ *    RetainerSet.c can simply do nothing.
  *    If this is not the case, we can free all the retainer sets and
  *    re-initialize the hash table.
  *    See refreshAllRetainerSet() in RetainerSet.c.
@@ -1179,19 +1059,88 @@ getRetainerFrom( StgClosure *c )
  *    s != NULL
  * -------------------------------------------------------------------------- */
 static inline void
-associate( StgClosure *c, RetainerSet *rsOfc, RetainerSet *s )
+associate( StgClosure *c, RetainerSet *s )
 {
-    nat cost_c;
-
-    cost_c = costPure(c);             // not cost(c)
-    if (rsOfc != NULL) {
-	ASSERT(rsOfc->cost >= cost_c);
-	rsOfc->cost -= cost_c;
-    }
     // StgWord has the same size as pointers, so the following type
     // casting is okay.
     RSET(c) = (RetainerSet *)((StgWord)s | flip);
-    s->cost += cost_c;
+}
+
+/* -----------------------------------------------------------------------------
+ * Call retainClosure for each of the closures in an SRT.
+ * ------------------------------------------------------------------------- */
+
+static inline void
+retainSRT (StgClosure **srt, nat srt_len, StgClosure *c, retainer c_child_r)
+{
+  StgClosure **srt_end;
+
+  srt_end = srt + srt_len;
+
+  for (; srt < srt_end; srt++) {
+    /* Special-case to handle references to closures hiding out in DLLs, since
+       double indirections required to get at those. The code generator knows
+       which is which when generating the SRT, so it stores the (indirect)
+       reference to the DLL closure in the table by first adding one to it.
+       We check for this here, and undo the addition before evacuating it.
+
+       If the SRT entry hasn't got bit 0 set, the SRT entry points to a
+       closure that's fixed at link-time, and no extra magic is required.
+    */
+#ifdef ENABLE_WIN32_DLL_SUPPORT
+    if ( (unsigned long)(*srt) & 0x1 ) {
+       retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)), 
+		     c, c_child_r);
+    } else {
+       retainClosure(*srt,c,c_child_r);
+    }
+#else
+    retainClosure(*srt,c,c_child_r);
+#endif
+  }
+}
+
+/* -----------------------------------------------------------------------------
+   Call retainClosure for each of the closures covered by a large bitmap.
+   -------------------------------------------------------------------------- */
+
+static void
+retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
+		     StgClosure *c, retainer c_child_r)
+{
+    nat i, b;
+    StgWord bitmap;
+    
+    b = 0;
+    bitmap = large_bitmap->bitmap[b];
+    for (i = 0; i < size; ) {
+	if ((bitmap & 1) == 0) {
+	    retainClosure((StgClosure *)*p, c, c_child_r);
+	}
+	i++;
+	p++;
+	if (i % BITS_IN(W_) == 0) {
+	    b++;
+	    bitmap = large_bitmap->bitmap[b];
+	} else {
+	    bitmap = bitmap >> 1;
+	}
+    }
+}
+
+static inline StgPtr
+retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
+		     StgClosure *c, retainer c_child_r)
+{
+    while (size > 0) {
+	if ((bitmap & 1) == 0) {
+	    retainClosure((StgClosure *)*p, c, c_child_r);
+	}
+	p++;
+	bitmap = bitmap >> 1;
+	size--;
+    }
+    return p;
 }
 
 /* -----------------------------------------------------------------------------
@@ -1200,9 +1149,7 @@ associate( StgClosure *c, RetainerSet *rsOfc, RetainerSet *s )
  *  respectively. Treat stackOptionalFun as another child of *c if it is
  *  not NULL.
  *  Invariants:
- *    *c is one of the following: TSO, PAP, and AP_UPD.
- *    If *c is AP_UPD or PAP, stackOptionalFun is not NULL. Otherwise,
- *    it is NULL.
+ *    *c is one of the following: TSO, AP_STACK.
  *    If *c is TSO, c == c_child_r.
  *    stackStart < stackEnd.
  *    RSET(c) and RSET(c_child_r) are valid, i.e., their
@@ -1215,14 +1162,14 @@ associate( StgClosure *c, RetainerSet *rsOfc, RetainerSet *s )
  *    retainClosure() is invoked instead of evacuate().
  * -------------------------------------------------------------------------- */
 static void
-retainStack( StgClosure *c, StgClosure *c_child_r,
-	     StgClosure *stackOptionalFun, StgPtr stackStart,
-	     StgPtr stackEnd )
+retainStack( StgClosure *c, retainer c_child_r,
+	     StgPtr stackStart, StgPtr stackEnd )
 {
     stackElement *oldStackBoundary;
-    StgPtr p, q;
-    StgInfoTable *info;
+    StgPtr p;
+    StgRetInfoTable *info;
     StgWord32 bitmap;
+    nat size;
 
 #ifdef DEBUG_RETAINER
     cStackSize++;
@@ -1242,62 +1189,16 @@ retainStack( StgClosure *c, StgClosure *c_child_r,
     // fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
 #endif
 
-    if (stackOptionalFun != NULL) {
-	ASSERT(get_itbl(c)->type == AP_UPD || get_itbl(c)->type == PAP);
-	retainClosure(stackOptionalFun, c, c_child_r);
-    } else {
-	ASSERT(get_itbl(c)->type == TSO);
-	ASSERT(((StgTSO *)c)->what_next != ThreadRelocated &&
-	       ((StgTSO *)c)->what_next != ThreadComplete &&
-	       ((StgTSO *)c)->what_next != ThreadKilled);
-    }
-
+    ASSERT(get_itbl(c)->type != TSO || 
+	   (((StgTSO *)c)->what_next != ThreadRelocated &&
+	    ((StgTSO *)c)->what_next != ThreadComplete &&
+	    ((StgTSO *)c)->what_next != ThreadKilled));
+    
     p = stackStart;
     while (p < stackEnd) {
-	q = *(StgPtr *)p;
-
-    //
-    // Note & Todo:
-    //   The correctness of retainer profiling is subject to the
-    //   correctness of the two macros IS_ARG_TAG() and
-    //   LOOKS_LIKE_GHC_INFO(). Since LOOKS_LIKE_GHC_INFO() is a bit
-    //   precarious macro, so I believe that the current
-    //   implementation may not be quite safe. Also, scavenge_stack()
-    //   in GC.c also exploits this macro in order to identify shallow
-    //   pointers.  I am not sure whether scavenge_stack() takes
-    //   further measurements to discern real shallow pointers.
-    //
-    //   I think this can be a serious problem if a stack chunk
-    //   contains some word which looks like a pointer but is
-    //   actually, say, a word constituting a floating number.
-    //
+	info = get_ret_itbl((StgClosure *)p);
 
-	// skip tagged words
-	if (IS_ARG_TAG((StgWord)q)) {
-	    p += 1 + ARG_SIZE(q);
-	    continue;
-	}
-
-	// check if *p is a shallow closure pointer
-	if (!LOOKS_LIKE_GHC_INFO(q)) {
-	    retainClosure((StgClosure *)q, c, c_child_r);
-	    p++;
-	    continue;
-	}
-
-	// regular stack objects
-	info = get_itbl((StgClosure *)p);
-	switch(info->type) {
-	case RET_DYN:
-	    bitmap = ((StgRetDyn *)p)->liveness;
-	    p = ((StgRetDyn *)p)->payload;
-	    goto small_bitmap;
-
-	    // FUN and FUN_STATIC keep only their info pointer.
-	case FUN:
-	case FUN_STATIC:
-	    p++;
-	    goto follow_srt;
+	switch(info->i.type) {
 
 	case UPDATE_FRAME:
 	    retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
@@ -1306,70 +1207,95 @@ retainStack( StgClosure *c, StgClosure *c_child_r,
 
 	case STOP_FRAME:
 	case CATCH_FRAME:
-	case SEQ_FRAME:
-	case RET_BCO:
 	case RET_SMALL:
 	case RET_VEC_SMALL:
-	    bitmap = info->layout.bitmap;
+	    bitmap = BITMAP_BITS(info->i.layout.bitmap);
+	    size   = BITMAP_SIZE(info->i.layout.bitmap);
 	    p++;
-	small_bitmap:
-	    while (bitmap != 0) {
-		if ((bitmap & 1) == 0)
-		    retainClosure((StgClosure *)*p, c, c_child_r);
-		p++;
-		bitmap = bitmap >> 1;
-	    }
+	    p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+
 	follow_srt:
-	    {
-		StgClosure **srt, **srt_end;
+	    retainSRT((StgClosure **)info->srt, info->i.srt_len, c, c_child_r);
+	    continue;
 
-		srt = (StgClosure **)(info->srt);
-		srt_end = srt + info->srt_len;
-		for (; srt < srt_end; srt++) {
-		    // See scavenge_srt() in GC.c for details.
-#ifdef ENABLE_WIN32_DLL_SUPPORT
-		    if ((unsigned long)(*srt) & 0x1)
-			retainClosure(*(StgClosure **)(((unsigned long)*srt & ~0x1)), c, c_child_r);
-		    else
-			retainClosure(*srt, c, c_child_r);
-#else
-		    retainClosure(*srt, c, c_child_r);
-#endif
-		}
-	    }
+	case RET_BCO: {
+	    StgBCO *bco;
+	    
+	    p++;
+	    retainClosure((StgClosure *)*p, c, c_child_r);
+	    bco = (StgBCO *)*p;
+	    p++;
+	    size = BCO_BITMAP_SIZE(bco);
+	    retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
+	    p += size;
 	    continue;
+	}
 
+	    // large bitmap (> 32 entries, or > 64 on a 64-bit machine) 
 	case RET_BIG:
 	case RET_VEC_BIG:
-	{
-	    StgPtr q;
-	    StgLargeBitmap *large_bitmap;
-	    nat i;
-
-	    large_bitmap = info->layout.large_bitmap;
+	    size = info->i.layout.large_bitmap->size;
 	    p++;
+	    retain_large_bitmap(p, info->i.layout.large_bitmap,
+				size, c, c_child_r);
+	    p += size;
+	    // and don't forget to follow the SRT 
+	    goto follow_srt;
 
-	    for (i = 0; i < large_bitmap->size; i++) {
-		bitmap = large_bitmap->bitmap[i];
-		q = p + sizeofW(StgWord) * 8;
-		while (bitmap != 0) {
-		    if ((bitmap & 1) == 0)
-			retainClosure((StgClosure *)*p, c, c_child_r);
-		    p++;
-		    bitmap = bitmap >> 1;
-		}
-		if (i + 1 < large_bitmap->size) {
-		    while (p < q) {
-			retainClosure((StgClosure *)*p, c, c_child_r);
-			p++;
-		    }
-		}
+	    // Dynamic bitmap: the mask is stored on the stack 
+	case RET_DYN: {
+	    StgWord dyn;
+	    dyn = ((StgRetDyn *)p)->liveness;
+
+	    // traverse the bitmap first
+	    bitmap = GET_LIVENESS(dyn);
+	    p      = (P_)&((StgRetDyn *)p)->payload[0];
+	    size   = RET_DYN_SIZE;
+	    p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+	    
+	    // skip over the non-ptr words
+	    p += GET_NONPTRS(dyn);
+	    
+	    // follow the ptr words
+	    for (size = GET_PTRS(dyn); size > 0; size--) {
+		retainClosure((StgClosure *)*p, c, c_child_r);
+		p++;
 	    }
+	    continue;
 	}
-	goto follow_srt;
+
+	case RET_FUN: {
+	    StgRetFun *ret_fun = (StgRetFun *)p;
+	    StgFunInfoTable *fun_info;
+	    
+	    retainClosure(ret_fun->fun, c, c_child_r);
+	    fun_info = get_fun_itbl(ret_fun->fun);
+	    
+	    p = (P_)&ret_fun->payload;
+	    switch (fun_info->fun_type) {
+	    case ARG_GEN:
+		bitmap = BITMAP_BITS(fun_info->bitmap);
+		size = BITMAP_SIZE(fun_info->bitmap);
+		p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+		break;
+	    case ARG_GEN_BIG:
+		size = ((StgLargeBitmap *)fun_info->bitmap)->size;
+		retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, 
+				    size, c, c_child_r);
+		p += size;
+		break;
+	    default:
+		bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+		size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
+		p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+		break;
+	    }
+	    goto follow_srt;
+	}
+
 	default:
 	    barf("Invalid object found in retainStack(): %d",
-		 (int)(info->type));
+		 (int)(info->i.type));
 	}
     }
 
@@ -1384,6 +1310,49 @@ retainStack( StgClosure *c, StgClosure *c_child_r,
 #endif
 }
 
+/* ----------------------------------------------------------------------------
+ * Call retainClosure for each of the children of a PAP/AP
+ * ------------------------------------------------------------------------- */
+
+static inline StgPtr
+retain_PAP (StgPAP *pap, retainer c_child_r)
+{
+    StgPtr p;
+    StgWord bitmap, size;
+    StgFunInfoTable *fun_info;
+
+    retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
+    fun_info = get_fun_itbl(pap->fun);
+    ASSERT(fun_info->i.type != PAP);
+
+    p = (StgPtr)pap->payload;
+    size = pap->n_args;
+
+    switch (fun_info->fun_type) {
+    case ARG_GEN:
+	bitmap = BITMAP_BITS(fun_info->bitmap);
+	p = retain_small_bitmap(p, pap->n_args, bitmap, 
+				(StgClosure *)pap, c_child_r);
+	break;
+    case ARG_GEN_BIG:
+	retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
+			    size, (StgClosure *)pap, c_child_r);
+	p += size;
+	break;
+    case ARG_BCO:
+	retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
+			    size, (StgClosure *)pap, c_child_r);
+	p += size;
+	break;
+    default:
+	bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+	p = retain_small_bitmap(p, pap->n_args, bitmap, 
+				(StgClosure *)pap, c_child_r);
+	break;
+    }
+    return p;
+}
+
 /* -----------------------------------------------------------------------------
  *  Compute the retainer set of *c0 and all its desecents by traversing.
  *  *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
@@ -1398,19 +1367,19 @@ retainStack( StgClosure *c, StgClosure *c_child_r,
  *    its descendants.
  *  Note:
  *    stackTop must be the same at the beginning and the exit of this function.
- *    *c0 can be TSO (as well as PAP and AP_UPD).
+ *    *c0 can be TSO (as well as AP_STACK).
  * -------------------------------------------------------------------------- */
 static void
-retainClosure( StgClosure *c0, StgClosure *cp0, StgClosure *r0 )
+retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
 {
     // c = Current closure
     // cp = Current closure's Parent
     // r = current closures' most recent Retainer
     // c_child_r = current closure's children's most recent retainer
     // first_child = first child of c
-    StgClosure *c, *cp, *r, *c_child_r, *first_child;
+    StgClosure *c, *cp, *first_child;
     RetainerSet *s, *retainerSetOfc;
-    retainer R_r;
+    retainer r, c_child_r;
     StgWord typeOfc;
 
 #ifdef DEBUG_RETAINER
@@ -1558,7 +1527,6 @@ inner_loop:
 	s = retainerSetOf(cp);
 
     // (c, cp, r, s) is available.
-    R_r = getRetainerFrom(r);
 
     // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
     if (retainerSetOfc == NULL) {
@@ -1566,31 +1534,31 @@ inner_loop:
 	numObjectVisited++;
 
 	if (s == NULL)
-	    associate(c, NULL, singleton(R_r));
+	    associate(c, singleton(r));
 	else
 	    // s is actually the retainer set of *c!
-	    associate(c, NULL, s);
+	    associate(c, s);
 
 	// compute c_child_r
-	c_child_r = isRetainer(c) ? c : r;
+	c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
     } else {
 	// This is not the first visit to *c.
-	if (isMember(R_r, retainerSetOfc))
+	if (isMember(r, retainerSetOfc))
 	    goto loop;          // no need to process child
 
 	if (s == NULL)
-	    associate(c, retainerSetOfc, addElement(R_r, retainerSetOfc));
+	    associate(c, addElement(r, retainerSetOfc));
 	else {
 	    // s is not NULL and cp is not a retainer. This means that
 	    // each time *cp is visited, so is *c. Thus, if s has
 	    // exactly one more element in its retainer set than c, s
 	    // is also the new retainer set for *c.
 	    if (s->num == retainerSetOfc->num + 1) {
-		associate(c, retainerSetOfc, s);
+		associate(c, s);
 	    }
 	    // Otherwise, just add R_r to the current retainer set of *c.
 	    else {
-		associate(c, retainerSetOfc, addElement(R_r, retainerSetOfc));
+		associate(c, addElement(r, retainerSetOfc));
 	    }
 	}
 
@@ -1606,27 +1574,27 @@ inner_loop:
 
     // process child
 
-    if (typeOfc == TSO) {
+    // 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 TSO:
 	retainStack(c, c_child_r,
-		    NULL,
 		    ((StgTSO *)c)->sp,
 		    ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
-	// no more children
 	goto loop;
-    } else if (typeOfc == PAP) {
-	retainStack(c, c_child_r,
-		    ((StgPAP *)c)->fun,
-		    (StgPtr)((StgPAP *)c)->payload,
-		    (StgPtr)((StgPAP *)c)->payload + ((StgPAP *)c)->n_args);
-	// no more children
+
+    case PAP:
+    case AP:
+	retain_PAP((StgPAP *)c, c_child_r);
 	goto loop;
-    } else if (typeOfc == AP_UPD) {
+
+    case AP_STACK:
+	retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
 	retainStack(c, c_child_r,
-		    ((StgAP_UPD *)c)->fun,
-		    (StgPtr)((StgAP_UPD *)c)->payload,
-		    (StgPtr)((StgAP_UPD *)c)->payload +
-		             ((StgAP_UPD *)c)->n_args);
-	// no more children
+		    (StgPtr)((StgAP_STACK *)c)->payload,
+		    (StgPtr)((StgAP_STACK *)c)->payload +
+		             ((StgAP_STACK *)c)->size);
 	goto loop;
     }
 
@@ -1657,7 +1625,11 @@ retainRoot( StgClosure **tl )
     ASSERT(isEmptyRetainerStack());
     currentStackBoundary = stackTop;
 
-    retainClosure(*tl, *tl, *tl);
+    if (isRetainer(*tl)) {
+	retainClosure(*tl, *tl, getRetainerFrom(*tl));
+    } else {
+	retainClosure(*tl, *tl, CCS_SYSTEM);
+    }
 
     // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
     // *tl might be a TSO which is ThreadComplete, in which
@@ -1689,6 +1661,9 @@ computeRetainerSet( void )
 	// retainRoot((StgClosure *)weak);
 	retainRoot((StgClosure **)&weak);
 
+    // Consider roots from the stable ptr table.
+    markStablePtrTable(retainRoot);
+
     // The following code resets the rs field of each unvisited mutable
     // object (computing sumOfNewCostExtra and updating costArray[] when
     // debugging retainer profiler).
@@ -1846,7 +1821,6 @@ resetStaticObjectForRetainerProfiling( void )
 void
 retainerProfile(void)
 {
-  nat allCost, numSet;
 #ifdef DEBUG_RETAINER
   nat i;
   nat totalHeapSize;        // total raw heap size (computed by linear scanning)
@@ -1923,8 +1897,6 @@ retainerProfile(void)
 #endif
   computeRetainerSet();
 
-  outputRetainerSet(hp_file, &allCost, &numSet);
-
 #ifdef DEBUG_RETAINER
   fprintf(stderr, "After traversing:\n");
   sumOfCostLinear = 0;
@@ -1978,8 +1950,7 @@ retainerProfile(void)
 #ifdef DEBUG_RETAINER
     maxCStackSize, maxStackSize,
 #endif
-    (double)timesAnyObjectVisited / numObjectVisited,
-    allCost, numSet);
+    (double)timesAnyObjectVisited / numObjectVisited);
 }
 
 /* -----------------------------------------------------------------------------
@@ -2038,10 +2009,13 @@ sanityCheckHeapClosure( StgClosure *c )
     case MUT_ARR_PTRS_FROZEN:
 	return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
 
-    case AP_UPD:
+    case AP:
     case PAP:
 	return pap_sizeW((StgPAP *)c);
 
+    case AP:
+	return ap_stack_sizeW((StgAP_STACK *)c);
+
     case ARR_WORDS:
 	return arr_words_sizeW((StgArrWords *)c);
 
@@ -2089,7 +2063,6 @@ sanityCheckHeapClosure( StgClosure *c )
     case UPDATE_FRAME:
     case CATCH_FRAME:
     case STOP_FRAME:
-    case SEQ_FRAME:
     case RET_DYN:
     case RET_BCO:
     case RET_SMALL: