X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FGC.c;h=66c53c4e2e086ef00d5d1cba2f8cf5b4e0c5cc8b;hb=b61f70ce5ff947642c96b1ad980351691bb1e07a;hp=2f11e8bb196fa1bef046e31fa555d247bce328de;hpb=d888cbcbaa3b4113fca39b9a0888b404ed8ec9b8;p=ghc-hetmet.git

diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 2f11e8b..66c53c4 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,31 +1,32 @@
 /* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.106 2001/07/24 06:31:36 ken Exp $
  *
- * (c) The GHC Team 1998-1999
+ * (c) The GHC Team 1998-2003
  *
  * Generational garbage collector
  *
  * ---------------------------------------------------------------------------*/
 
+#include "PosixSource.h"
 #include "Rts.h"
 #include "RtsFlags.h"
 #include "RtsUtils.h"
+#include "Apply.h"
 #include "Storage.h"
-#include "StoragePriv.h"
+#include "LdvProfile.h"
+#include "Updates.h"
 #include "Stats.h"
 #include "Schedule.h"
-#include "SchedAPI.h"		// for ReverCAFs prototype
 #include "Sanity.h"
 #include "BlockAlloc.h"
 #include "MBlock.h"
-#include "Main.h"
 #include "ProfHeap.h"
 #include "SchedAPI.h"
 #include "Weak.h"
-#include "StablePriv.h"
 #include "Prelude.h"
 #include "ParTicky.h"		// ToDo: move into Rts.h
 #include "GCCompact.h"
+#include "Signals.h"
+#include "STM.h"
 #if defined(GRAN) || defined(PAR)
 # include "GranSimRts.h"
 # include "ParallelRts.h"
@@ -40,7 +41,10 @@
 #if defined(RTS_GTK_FRONTPANEL)
 #include "FrontPanel.h"
 #endif
-#include <stddef.h>
+
+#include "RetainerProfile.h"
+
+#include <string.h>
 
 /* STATIC OBJECT LIST.
  *
@@ -76,8 +80,8 @@
  * We build up a static object list while collecting generations 0..N,
  * which is then appended to the static object list of generation N+1.
  */
-StgClosure* static_objects;	      // live static objects
-StgClosure* scavenged_static_objects; // static objects scavenged so far
+static StgClosure* static_objects;      // live static objects
+StgClosure* scavenged_static_objects;   // static objects scavenged so far
 
 /* N is the oldest generation being collected, where the generations
  * are numbered starting at 0.  A major GC (indicated by the major_gc
@@ -96,12 +100,17 @@ static nat evac_gen;
 /* Weak pointers
  */
 StgWeak *old_weak_ptr_list; // also pending finaliser list
-static rtsBool weak_done;	   // all done for this pass
+
+/* Which stage of processing various kinds of weak pointer are we at?
+ * (see traverse_weak_ptr_list() below for discussion).
+ */
+typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
+static WeakStage weak_stage;
 
 /* List of all threads during GC
  */
 static StgTSO *old_all_threads;
-static StgTSO *resurrected_threads;
+StgTSO *resurrected_threads;
 
 /* Flag indicating failure to evacuate an object to the desired
  * generation.
@@ -110,39 +119,55 @@ static rtsBool failed_to_evac;
 
 /* Old to-space (used for two-space collector only)
  */
-bdescr *old_to_blocks;
+static bdescr *old_to_blocks;
 
 /* Data used for allocation area sizing.
  */
-lnat new_blocks;		// blocks allocated during this GC 
-lnat g0s0_pcnt_kept = 30;	// percentage of g0s0 live at last minor GC 
+static lnat new_blocks;		 // blocks allocated during this GC 
+static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC 
 
 /* Used to avoid long recursion due to selector thunks
  */
-lnat thunk_selector_depth = 0;
-#define MAX_THUNK_SELECTOR_DEPTH 256
+static lnat thunk_selector_depth = 0;
+#define MAX_THUNK_SELECTOR_DEPTH 8
 
 /* -----------------------------------------------------------------------------
    Static function declarations
    -------------------------------------------------------------------------- */
 
+static bdescr *     gc_alloc_block          ( step *stp );
 static void         mark_root               ( StgClosure **root );
-static StgClosure * evacuate                ( StgClosure *q );
+
+// Use a register argument for evacuate, if available.
+#if __GNUC__ >= 2
+#define REGPARM1 __attribute__((regparm(1)))
+#else
+#define REGPARM1
+#endif
+
+REGPARM1 static StgClosure * evacuate (StgClosure *q);
+
 static void         zero_static_object_list ( StgClosure* first_static );
 static void         zero_mutable_list       ( StgMutClosure *first );
 
 static rtsBool      traverse_weak_ptr_list  ( void );
-static void         cleanup_weak_ptr_list   ( StgWeak **list );
-
-static void         scavenge                ( step * );
-static void         scavenge_mark_stack     ( void );
-static void         scavenge_stack          ( StgPtr p, StgPtr stack_end );
-static rtsBool      scavenge_one            ( StgClosure *p );
-static void         scavenge_large          ( step * );
-static void         scavenge_static         ( void );
-static void         scavenge_mutable_list   ( generation *g );
-static void         scavenge_mut_once_list  ( generation *g );
-static void         scavengeCAFs            ( void );
+static void         mark_weak_ptr_list      ( StgWeak **list );
+
+static StgClosure * eval_thunk_selector     ( nat field, StgSelector * p );
+
+
+static void    scavenge                ( step * );
+static void    scavenge_mark_stack     ( void );
+static void    scavenge_stack          ( StgPtr p, StgPtr stack_end );
+static rtsBool scavenge_one            ( StgPtr p );
+static void    scavenge_large          ( step * );
+static void    scavenge_static         ( void );
+static void    scavenge_mutable_list   ( generation *g );
+static void    scavenge_mut_once_list  ( generation *g );
+
+static void    scavenge_large_bitmap   ( StgPtr p, 
+					 StgLargeBitmap *large_bitmap, 
+					 nat size );
 
 #if 0 && defined(DEBUG)
 static void         gcCAFs                  ( void );
@@ -159,51 +184,112 @@ static StgPtr *mark_stack;
 static StgPtr *mark_sp;
 static StgPtr *mark_splim;
 
-static inline rtsBool
+// Flag and pointers used for falling back to a linear scan when the
+// mark stack overflows.
+static rtsBool mark_stack_overflowed;
+static bdescr *oldgen_scan_bd;
+static StgPtr  oldgen_scan;
+
+STATIC_INLINE rtsBool
 mark_stack_empty(void)
 {
     return mark_sp == mark_stack;
 }
 
-static inline rtsBool
+STATIC_INLINE rtsBool
 mark_stack_full(void)
 {
     return mark_sp >= mark_splim;
 }
 
-static inline void
+STATIC_INLINE void
+reset_mark_stack(void)
+{
+    mark_sp = mark_stack;
+}
+
+STATIC_INLINE void
 push_mark_stack(StgPtr p)
 {
     *mark_sp++ = p;
 }
 
-static inline StgPtr
+STATIC_INLINE StgPtr
 pop_mark_stack(void)
 {
     return *--mark_sp;
 }
 
 /* -----------------------------------------------------------------------------
+   Allocate a new to-space block in the given step.
+   -------------------------------------------------------------------------- */
+
+static bdescr *
+gc_alloc_block(step *stp)
+{
+    bdescr *bd = allocBlock();
+    bd->gen_no = stp->gen_no;
+    bd->step = stp;
+    bd->link = NULL;
+
+    // blocks in to-space in generations up to and including N
+    // get the BF_EVACUATED flag.
+    if (stp->gen_no <= N) {
+	bd->flags = BF_EVACUATED;
+    } else {
+	bd->flags = 0;
+    }
+
+    // Start a new to-space block, chain it on after the previous one.
+    if (stp->hp_bd == NULL) {
+	stp->hp_bd = bd;
+    } else {
+	stp->hp_bd->free = stp->hp;
+	stp->hp_bd->link = bd;
+	stp->hp_bd = bd;
+    }
+
+    stp->hp    = bd->start;
+    stp->hpLim = stp->hp + BLOCK_SIZE_W;
+
+    stp->n_to_blocks++;
+    new_blocks++;
+
+    return bd;
+}
+
+/* -----------------------------------------------------------------------------
    GarbageCollect
 
-   For garbage collecting generation N (and all younger generations):
+   Rough outline of the algorithm: for garbage collecting generation N
+   (and all younger generations):
 
      - follow all pointers in the root set.  the root set includes all 
-       mutable objects in all steps in all generations.
+       mutable objects in all generations (mutable_list and mut_once_list).
 
      - for each pointer, evacuate the object it points to into either
-       + to-space in the next higher step in that generation, if one exists,
-       + if the object's generation == N, then evacuate it to the next
-         generation if one exists, or else to-space in the current
-	 generation.
-       + if the object's generation < N, then evacuate it to to-space
-         in the next generation.
+
+       + to-space of the step given by step->to, which is the next
+         highest step in this generation or the first step in the next
+         generation if this is the last step.
+
+       + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
+         When we evacuate an object we attempt to evacuate
+         everything it points to into the same generation - this is
+         achieved by setting evac_gen to the desired generation.  If
+         we can't do this, then an entry in the mut_once list has to
+         be made for the cross-generation pointer.
+
+       + if the object is already in a generation > N, then leave
+         it alone.
 
      - repeatedly scavenge to-space from each step in each generation
        being collected until no more objects can be evacuated.
       
      - free from-space in each step, and set from-space = to-space.
 
+   Locks held: sched_mutex
+
    -------------------------------------------------------------------------- */
 
 void
@@ -212,6 +298,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   bdescr *bd;
   step *stp;
   lnat live, allocated, collected = 0, copied = 0;
+  lnat oldgen_saved_blocks = 0;
   nat g, s;
 
 #ifdef PROFILING
@@ -219,10 +306,18 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 #endif
 
 #if defined(DEBUG) && defined(GRAN)
-  IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n", 
+  IF_DEBUG(gc, debugBelch("@@ Starting garbage collection at %ld (%lx)\n", 
 		     Now, Now));
 #endif
 
+#if defined(RTS_USER_SIGNALS)
+  // block signals
+  blockUserSignals();
+#endif
+
+  // tell the STM to discard any cached closures its hoping to re-use
+  stmPreGCHook();
+
   // tell the stats department that we've started a GC 
   stat_startGC();
 
@@ -248,7 +343,9 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   } else {
     N = 0;
     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
-      if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
+      if (generations[g].steps[0].n_blocks +
+	  generations[g].steps[0].n_large_blocks
+	  >= generations[g].max_blocks) {
         N = g;
       }
     }
@@ -284,6 +381,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   if (RtsFlags.GcFlags.generations == 1) {
     old_to_blocks = g0s0->to_blocks;
     g0s0->to_blocks = NULL;
+    g0s0->n_to_blocks = 0;
   }
 
   /* Keep a count of how many new blocks we allocated during this GC
@@ -291,9 +389,9 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
    */
   new_blocks = 0;
 
-  /* Initialise to-space in all the generations/steps that we're
-   * collecting.
-   */
+  // Initialise to-space in all the generations/steps that we're
+  // collecting.
+  //
   for (g = 0; g <= N; g++) {
     generations[g].mut_once_list = END_MUT_LIST;
     generations[g].mut_list = END_MUT_LIST;
@@ -305,30 +403,29 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 	continue; 
       }
 
-      /* Get a free block for to-space.  Extra blocks will be chained on
-       * as necessary.
-       */
-      bd = allocBlock();
       stp = &generations[g].steps[s];
       ASSERT(stp->gen_no == g);
-      ASSERT(stp->hp ? Bdescr(stp->hp)->step == stp : rtsTrue);
-      bd->gen_no = g;
-      bd->step = stp;
-      bd->link = NULL;
-      bd->flags        = BF_EVACUATED;	// it's a to-space block 
-      stp->hp          = bd->start;
-      stp->hpLim       = stp->hp + BLOCK_SIZE_W;
-      stp->hp_bd       = bd;
+
+      // start a new to-space for this step.
+      stp->hp        = NULL;
+      stp->hp_bd     = NULL;
+      stp->to_blocks = NULL;
+
+      // allocate the first to-space block; extra blocks will be
+      // chained on as necessary.
+      bd = gc_alloc_block(stp);
       stp->to_blocks   = bd;
-      stp->n_to_blocks = 1;
       stp->scan        = bd->start;
       stp->scan_bd     = bd;
+
+      // initialise the large object queues.
       stp->new_large_objects = NULL;
       stp->scavenged_large_objects = NULL;
-      new_blocks++;
+      stp->n_scavenged_large_blocks = 0;
+
       // mark the large objects as not evacuated yet 
       for (bd = stp->large_objects; bd; bd = bd->link) {
-	bd->flags = BF_LARGE;
+	bd->flags &= ~BF_EVACUATED;
       }
 
       // for a compacted step, we need to allocate the bitmap
@@ -345,17 +442,24 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 	      stp->bitmap = bitmap_bdescr;
 	      bitmap = bitmap_bdescr->start;
 	      
-	      IF_DEBUG(gc, fprintf(stderr, "bitmap_size: %d, bitmap: %p\n",
+	      IF_DEBUG(gc, debugBelch("bitmap_size: %d, bitmap: %p",
 				   bitmap_size, bitmap););
 	      
 	      // don't forget to fill it with zeros!
 	      memset(bitmap, 0, bitmap_size);
 	      
-	      // for each block in this step, point to its bitmap from the
+	      // For each block in this step, point to its bitmap from the
 	      // block descriptor.
 	      for (bd=stp->blocks; bd != NULL; bd = bd->link) {
 		  bd->u.bitmap = bitmap;
 		  bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
+
+		  // Also at this point we set the BF_COMPACTED flag
+		  // for this block.  The invariant is that
+		  // BF_COMPACTED is always unset, except during GC
+		  // when it is set on those blocks which will be
+		  // compacted.
+		  bd->flags |= BF_COMPACTED;
 	      }
 	  }
       }
@@ -363,24 +467,16 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   }
 
   /* make sure the older generations have at least one block to
-   * allocate into (this makes things easier for copy(), see below.
+   * allocate into (this makes things easier for copy(), see below).
    */
   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
     for (s = 0; s < generations[g].n_steps; s++) {
       stp = &generations[g].steps[s];
       if (stp->hp_bd == NULL) {
 	  ASSERT(stp->blocks == NULL);
-	  bd = allocBlock();
-	  bd->gen_no = g;
-	  bd->step = stp;
-	  bd->link = NULL;
-	  bd->flags = 0;	// *not* a to-space block or a large object
-	  stp->hp = bd->start;
-	  stp->hpLim = stp->hp + BLOCK_SIZE_W;
-	  stp->hp_bd = bd;
+	  bd = gc_alloc_block(stp);
 	  stp->blocks = bd;
 	  stp->n_blocks = 1;
-	  new_blocks++;
       }
       /* Set the scan pointer for older generations: remember we
        * still have to scavenge objects that have been promoted. */
@@ -390,6 +486,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
       stp->n_to_blocks = 0;
       stp->new_large_objects = NULL;
       stp->scavenged_large_objects = NULL;
+      stp->n_scavenged_large_blocks = 0;
     }
   }
 
@@ -445,7 +542,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
     }
   }
 
-  scavengeCAFs();
+  /* follow roots from the CAF list (used by GHCi)
+   */
+  evac_gen = 0;
+  markCAFs(mark_root);
 
   /* follow all the roots that the application knows about.
    */
@@ -470,9 +570,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   /* Mark the weak pointer list, and prepare to detect dead weak
    * pointers.
    */
+  mark_weak_ptr_list(&weak_ptr_list);
   old_weak_ptr_list = weak_ptr_list;
   weak_ptr_list = NULL;
-  weak_done = rtsFalse;
+  weak_stage = WeakPtrs;
 
   /* The all_threads list is like the weak_ptr_list.  
    * See traverse_weak_ptr_list() for the details.
@@ -485,17 +586,6 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
    */
   markStablePtrTable(mark_root);
 
-#ifdef INTERPRETER
-  { 
-      /* ToDo: To fix the caf leak, we need to make the commented out
-       * parts of this code do something sensible - as described in 
-       * the CAF document.
-       */
-      extern void markHugsObjects(void);
-      markHugsObjects();
-  }
-#endif
-
   /* -------------------------------------------------------------------------
    * Repeatedly scavenge all the areas we know about until there's no
    * more scavenging to be done.
@@ -511,12 +601,6 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 	scavenge_static();
     }
 
-    // scavenge objects in compacted generation
-    if (mark_stack_bdescr != NULL && !mark_stack_empty()) {
-	scavenge_mark_stack();
-	flag = rtsTrue;
-    }
-
     /* When scavenging the older generations:  Objects may have been
      * evacuated from generations <= N into older generations, and we
      * need to scavenge these objects.  We're going to try to ensure that
@@ -530,7 +614,15 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
     { 
       long gen;
       int st; 
+
     loop2:
+      // scavenge objects in compacted generation
+      if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
+	  (mark_stack_bdescr != NULL && !mark_stack_empty())) {
+	  scavenge_mark_stack();
+	  flag = rtsTrue;
+      }
+
       for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
 	for (st = generations[gen].n_steps; --st >= 0; ) {
 	  if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) { 
@@ -554,16 +646,31 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 
     if (flag) { goto loop; }
 
-    // must be last... 
+    // must be last...  invariant is that everything is fully
+    // scavenged at this point.
     if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something 
       goto loop;
     }
   }
 
-  /* Final traversal of the weak pointer list (see comment by
-   * cleanUpWeakPtrList below).
+  /* Update the pointers from the "main thread" list - these are
+   * treated as weak pointers because we want to allow a main thread
+   * to get a BlockedOnDeadMVar exception in the same way as any other
+   * thread.  Note that the threads should all have been retained by
+   * GC by virtue of being on the all_threads list, we're just
+   * updating pointers here.
    */
-  cleanup_weak_ptr_list(&weak_ptr_list);
+  {
+      StgMainThread *m;
+      StgTSO *tso;
+      for (m = main_threads; m != NULL; m = m->link) {
+	  tso = (StgTSO *) isAlive((StgClosure *)m->tso);
+	  if (tso == NULL) {
+	      barf("main thread has been GC'd");
+	  }
+	  m->tso = tso;
+      }
+  }
 
 #if defined(PAR)
   // Reconstruct the Global Address tables used in GUM 
@@ -579,15 +686,25 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
       for (s = 0; s < generations[g].n_steps; s++) {
 	  stp = &generations[g].steps[s];
 	  if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
+	      ASSERT(Bdescr(stp->hp) == stp->hp_bd);
 	      stp->hp_bd->free = stp->hp;
-	      stp->hp_bd->link = NULL;
 	  }
       }
   }
 
+#ifdef PROFILING
+  // We call processHeapClosureForDead() on every closure destroyed during
+  // the current garbage collection, so we invoke LdvCensusForDead().
+  if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
+      || RtsFlags.ProfFlags.bioSelector != NULL)
+    LdvCensusForDead(N);
+#endif
+
   // NO MORE EVACUATION AFTER THIS POINT!
   // Finally: compaction of the oldest generation.
-  if (major_gc && RtsFlags.GcFlags.compact) { 
+  if (major_gc && oldest_gen->steps[0].is_compacted) {
+      // save number of blocks for stats
+      oldgen_saved_blocks = oldest_gen->steps[0].n_blocks;
       compact(get_roots);
   }
 
@@ -617,7 +734,12 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
       // for generations we collected... 
       if (g <= N) {
 
-	collected += stp->n_blocks * BLOCK_SIZE_W; // for stats 
+	  // rough calculation of garbage collected, for stats output
+	  if (stp->is_compacted) {
+	      collected += (oldgen_saved_blocks - stp->n_blocks) * BLOCK_SIZE_W;
+	  } else {
+	      collected += stp->n_blocks * BLOCK_SIZE_W;
+	  }
 
 	/* free old memory and shift to-space into from-space for all
 	 * the collected steps (except the allocation area).  These
@@ -628,7 +750,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 		// for a compacted step, just shift the new to-space
 		// onto the front of the now-compacted existing blocks.
 		for (bd = stp->to_blocks; bd != NULL; bd = bd->link) {
-		    bd->flags &= ~BF_EVACUATED;	// now from-space 
+		    bd->flags &= ~BF_EVACUATED;  // now from-space 
 		}
 		// tack the new blocks on the end of the existing blocks
 		if (stp->blocks == NULL) {
@@ -639,6 +761,11 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 			if (next == NULL) {
 			    bd->link = stp->to_blocks;
 			}
+			// NB. this step might not be compacted next
+			// time, so reset the BF_COMPACTED flags.
+			// They are set before GC if we're going to
+			// compact.  (search for BF_COMPACTED above).
+			bd->flags &= ~BF_COMPACTED;
 		    }
 		}
 		// add the new blocks to the block tally
@@ -648,7 +775,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 		stp->blocks = stp->to_blocks;
 		stp->n_blocks = stp->n_to_blocks;
 		for (bd = stp->blocks; bd != NULL; bd = bd->link) {
-		    bd->flags &= ~BF_EVACUATED;	// now from-space 
+		    bd->flags &= ~BF_EVACUATED;	 // now from-space 
 		}
 	    }
 	    stp->to_blocks = NULL;
@@ -665,29 +792,16 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 	  freeGroup(bd);
 	  bd = next;
 	}
+
+	// update the count of blocks used by large objects
 	for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
 	  bd->flags &= ~BF_EVACUATED;
 	}
-	stp->large_objects = stp->scavenged_large_objects;
-
-	/* Set the maximum blocks for this generation, interpolating
-	 * between the maximum size of the oldest and youngest
-	 * generations.
-	 *
-	 * max_blocks =    oldgen_max_blocks * G
-	 *                 ----------------------
-	 *                      oldest_gen
-	 */
-	if (g != 0) {
-#if 0
-	  generations[g].max_blocks = (oldest_gen->max_blocks * g)
-	       / (RtsFlags.GcFlags.generations-1);
-#endif
-	  generations[g].max_blocks = oldest_gen->max_blocks;
-	}
+	stp->large_objects  = stp->scavenged_large_objects;
+	stp->n_large_blocks = stp->n_scavenged_large_blocks;
 
-      // for older generations... 
       } else {
+	// for older generations... 
 	
 	/* For older generations, we need to append the
 	 * scavenged_large_object list (i.e. large objects that have been
@@ -701,34 +815,89 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 
 	// add the new blocks we promoted during this GC 
 	stp->n_blocks += stp->n_to_blocks;
+	stp->n_to_blocks = 0;
+	stp->n_large_blocks += stp->n_scavenged_large_blocks;
       }
     }
   }
-  
-  /* Set the maximum blocks for the oldest generation, based on twice
-   * the amount of live data now, adjusted to fit the maximum heap
-   * size if necessary.  
+
+  /* Reset the sizes of the older generations when we do a major
+   * collection.
    *
-   * This is an approximation, since in the worst case we'll need
-   * twice the amount of live data plus whatever space the other
-   * generations need.
+   * CURRENT STRATEGY: make all generations except zero the same size.
+   * We have to stay within the maximum heap size, and leave a certain
+   * percentage of the maximum heap size available to allocate into.
    */
   if (major_gc && RtsFlags.GcFlags.generations > 1) {
-      oldest_gen->max_blocks = 
-	stg_max(oldest_gen->steps[0].n_blocks * RtsFlags.GcFlags.oldGenFactor,
-		RtsFlags.GcFlags.minOldGenSize);
-      if (oldest_gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
-	oldest_gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
-	if (((int)oldest_gen->max_blocks - 
-	     (int)oldest_gen->steps[0].n_blocks) < 
-	    (RtsFlags.GcFlags.pcFreeHeap *
-	     RtsFlags.GcFlags.maxHeapSize / 200)) {
-	  heapOverflow();
-	}
+      nat live, size, min_alloc;
+      nat max  = RtsFlags.GcFlags.maxHeapSize;
+      nat gens = RtsFlags.GcFlags.generations;
+
+      // live in the oldest generations
+      live = oldest_gen->steps[0].n_blocks +
+	     oldest_gen->steps[0].n_large_blocks;
+
+      // default max size for all generations except zero
+      size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
+		     RtsFlags.GcFlags.minOldGenSize);
+
+      // minimum size for generation zero
+      min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
+			  RtsFlags.GcFlags.minAllocAreaSize);
+
+      // Auto-enable compaction when the residency reaches a
+      // certain percentage of the maximum heap size (default: 30%).
+      if (RtsFlags.GcFlags.generations > 1 &&
+	  (RtsFlags.GcFlags.compact ||
+	   (max > 0 &&
+	    oldest_gen->steps[0].n_blocks > 
+	    (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
+	  oldest_gen->steps[0].is_compacted = 1;
+//	  debugBelch("compaction: on\n", live);
+      } else {
+	  oldest_gen->steps[0].is_compacted = 0;
+//	  debugBelch("compaction: off\n", live);
+      }
+
+      // if we're going to go over the maximum heap size, reduce the
+      // size of the generations accordingly.  The calculation is
+      // different if compaction is turned on, because we don't need
+      // to double the space required to collect the old generation.
+      if (max != 0) {
+
+	  // this test is necessary to ensure that the calculations
+	  // below don't have any negative results - we're working
+	  // with unsigned values here.
+	  if (max < min_alloc) {
+	      heapOverflow();
+	  }
+
+	  if (oldest_gen->steps[0].is_compacted) {
+	      if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
+		  size = (max - min_alloc) / ((gens - 1) * 2 - 1);
+	      }
+	  } else {
+	      if ( (size * (gens - 1) * 2) + min_alloc > max ) {
+		  size = (max - min_alloc) / ((gens - 1) * 2);
+	      }
+	  }
+
+	  if (size < live) {
+	      heapOverflow();
+	  }
+      }
+
+#if 0
+      debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
+	      min_alloc, size, max);
+#endif
+
+      for (g = 0; g < gens; g++) {
+	  generations[g].max_blocks = size;
       }
   }
 
-  // Guess the amount of live data for stats. 
+  // Guess the amount of live data for stats.
   live = calcLive();
 
   /* Free the small objects allocated via allocate(), since this will
@@ -743,6 +912,9 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   alloc_HpLim = NULL;
   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 
+  // Start a new pinned_object_block
+  pinned_object_block = NULL;
+
   /* Free the mark stack.
    */
   if (mark_stack_bdescr != NULL) {
@@ -776,9 +948,9 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
     /* For a two-space collector, we need to resize the nursery. */
     
     /* set up a new nursery.  Allocate a nursery size based on a
-     * function of the amount of live data (currently a factor of 2,
-     * should be configurable (ToDo)).  Use the blocks from the old
-     * nursery if possible, freeing up any left over blocks.
+     * function of the amount of live data (by default a factor of 2)
+     * Use the blocks from the old nursery if possible, freeing up any
+     * left over blocks.
      *
      * If we get near the maximum heap size, then adjust our nursery
      * size accordingly.  If the nursery is the same size as the live
@@ -787,17 +959,18 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
      * 
      * A normal 2-space collector would need 4L bytes to give the same
      * performance we get from 3L bytes, reducing to the same
-     * performance at 2L bytes.  
+     * performance at 2L bytes.
      */
     blocks = g0s0->n_to_blocks;
 
-    if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 > 
-	 RtsFlags.GcFlags.maxHeapSize ) {
+    if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
+	 blocks * RtsFlags.GcFlags.oldGenFactor * 2 > 
+	   RtsFlags.GcFlags.maxHeapSize ) {
       long adjusted_blocks;  // signed on purpose 
       int pc_free; 
       
       adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
-      IF_DEBUG(gc, fprintf(stderr, "@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
+      IF_DEBUG(gc, debugBelch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
       pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
       if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
 	heapOverflow();
@@ -823,7 +996,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
       nat needed = calcNeeded(); 	// approx blocks needed at next GC 
 
       /* Guess how much will be live in generation 0 step 0 next time.
-       * A good approximation is the obtained by finding the
+       * A good approximation is obtained by finding the
        * percentage of g0s0 that was live at the last minor GC.
        */
       if (N == 0) {
@@ -851,6 +1024,11 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
       }
       
       resizeNursery((nat)blocks);
+
+    } else {
+      // we might have added extra large blocks to the nursery, so
+      // resize back to minAllocAreaSize again.
+      resizeNursery(RtsFlags.GcFlags.minAllocAreaSize);
     }
   }
 
@@ -859,20 +1037,29 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   if (major_gc) { gcCAFs(); }
 #endif
   
+#ifdef PROFILING
+  // resetStaticObjectForRetainerProfiling() must be called before
+  // zeroing below.
+  resetStaticObjectForRetainerProfiling();
+#endif
+
   // zero the scavenged static object list 
   if (major_gc) {
     zero_static_object_list(scavenged_static_objects);
   }
 
-  /* Reset the nursery
-   */
+  // Reset the nursery
   resetNurseries();
 
+  RELEASE_LOCK(&sched_mutex);
+  
   // start any pending finalizers 
   scheduleFinalizers(old_weak_ptr_list);
   
   // send exceptions to any threads which were about to die 
   resurrectThreads(resurrected_threads);
+  
+  ACQUIRE_LOCK(&sched_mutex);
 
   // Update the stable pointer hash table.
   updateStablePtrTable(major_gc);
@@ -890,7 +1077,6 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 
   // restore enclosing cost centre 
 #ifdef PROFILING
-  heapCensus();
   CCCS = prev_CCS;
 #endif
 
@@ -906,6 +1092,11 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
   // ok, GC over: tell the stats department what happened. 
   stat_endGC(allocated, collected, live, copied, N);
 
+#if defined(RTS_USER_SIGNALS)
+  // unblock signals again
+  unblockUserSignals();
+#endif
+
   //PAR_TICKY_TP();
 }
 
@@ -928,6 +1119,30 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
    older generations than the one we're collecting.  This could
    probably be optimised by keeping per-generation lists of weak
    pointers, but for a few weak pointers this scheme will work.
+
+   There are three distinct stages to processing weak pointers:
+
+   - weak_stage == WeakPtrs
+
+     We process all the weak pointers whos keys are alive (evacuate
+     their values and finalizers), and repeat until we can find no new
+     live keys.  If no live keys are found in this pass, then we
+     evacuate the finalizers of all the dead weak pointers in order to
+     run them.
+
+   - weak_stage == WeakThreads
+
+     Now, we discover which *threads* are still alive.  Pointers to
+     threads from the all_threads and main thread lists are the
+     weakest of all: a pointers from the finalizer of a dead weak
+     pointer can keep a thread alive.  Any threads found to be unreachable
+     are evacuated and placed on the resurrected_threads list so we 
+     can send them a signal later.
+
+   - weak_stage == WeakDone
+
+     No more evacuation is done.
+
    -------------------------------------------------------------------------- */
 
 static rtsBool 
@@ -937,137 +1152,155 @@ traverse_weak_ptr_list(void)
   StgClosure *new;
   rtsBool flag = rtsFalse;
 
-  if (weak_done) { return rtsFalse; }
-
-  /* doesn't matter where we evacuate values/finalizers to, since
-   * these pointers are treated as roots (iff the keys are alive).
-   */
-  evac_gen = 0;
-
-  last_w = &old_weak_ptr_list;
-  for (w = old_weak_ptr_list; w != NULL; w = next_w) {
-
-    /* First, this weak pointer might have been evacuated.  If so,
-     * remove the forwarding pointer from the weak_ptr_list.
-     */
-    if (get_itbl(w)->type == EVACUATED) {
-      w = (StgWeak *)((StgEvacuated *)w)->evacuee;
-      *last_w = w;
-    }
-
-    /* There might be a DEAD_WEAK on the list if finalizeWeak# was
-     * called on a live weak pointer object.  Just remove it.
-     */
-    if (w->header.info == &stg_DEAD_WEAK_info) {
-      next_w = ((StgDeadWeak *)w)->link;
-      *last_w = next_w;
-      continue;
-    }
-
-    ASSERT(get_itbl(w)->type == WEAK);
+  switch (weak_stage) {
 
-    /* Now, check whether the key is reachable.
-     */
-    if ((new = isAlive(w->key))) {
-      w->key = new;
-      // evacuate the value and finalizer 
-      w->value = evacuate(w->value);
-      w->finalizer = evacuate(w->finalizer);
-      // remove this weak ptr from the old_weak_ptr list 
-      *last_w = w->link;
-      // and put it on the new weak ptr list 
-      next_w  = w->link;
-      w->link = weak_ptr_list;
-      weak_ptr_list = w;
-      flag = rtsTrue;
-      IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
-      continue;
-    }
-    else {
-      last_w = &(w->link);
-      next_w = w->link;
-      continue;
-    }
-  }
+  case WeakDone:
+      return rtsFalse;
 
-  /* Now deal with the all_threads list, which behaves somewhat like
-   * the weak ptr list.  If we discover any threads that are about to
-   * become garbage, we wake them up and administer an exception.
-   */
-  {
-    StgTSO *t, *tmp, *next, **prev;
+  case WeakPtrs:
+      /* doesn't matter where we evacuate values/finalizers to, since
+       * these pointers are treated as roots (iff the keys are alive).
+       */
+      evac_gen = 0;
+      
+      last_w = &old_weak_ptr_list;
+      for (w = old_weak_ptr_list; w != NULL; w = next_w) {
+	  
+	  /* There might be a DEAD_WEAK on the list if finalizeWeak# was
+	   * called on a live weak pointer object.  Just remove it.
+	   */
+	  if (w->header.info == &stg_DEAD_WEAK_info) {
+	      next_w = ((StgDeadWeak *)w)->link;
+	      *last_w = next_w;
+	      continue;
+	  }
+	  
+	  switch (get_itbl(w)->type) {
 
-    prev = &old_all_threads;
-    for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
+	  case EVACUATED:
+	      next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
+	      *last_w = next_w;
+	      continue;
 
-      (StgClosure *)tmp = isAlive((StgClosure *)t);
-      
-      if (tmp != NULL) {
-	  t = tmp;
-      }
+	  case WEAK:
+	      /* Now, check whether the key is reachable.
+	       */
+	      new = isAlive(w->key);
+	      if (new != NULL) {
+		  w->key = new;
+		  // evacuate the value and finalizer 
+		  w->value = evacuate(w->value);
+		  w->finalizer = evacuate(w->finalizer);
+		  // remove this weak ptr from the old_weak_ptr list 
+		  *last_w = w->link;
+		  // and put it on the new weak ptr list 
+		  next_w  = w->link;
+		  w->link = weak_ptr_list;
+		  weak_ptr_list = w;
+		  flag = rtsTrue;
+		  IF_DEBUG(weak, debugBelch("Weak pointer still alive at %p -> %p", 
+				       w, w->key));
+		  continue;
+	      }
+	      else {
+		  last_w = &(w->link);
+		  next_w = w->link;
+		  continue;
+	      }
 
-      ASSERT(get_itbl(t)->type == TSO);
-      switch (t->what_next) {
-      case ThreadRelocated:
-	  next = t->link;
-	  *prev = next;
-	  continue;
-      case ThreadKilled:
-      case ThreadComplete:
-	  // finshed or died.  The thread might still be alive, but we
-	  // don't keep it on the all_threads list.  Don't forget to
-	  // stub out its global_link field.
-	  next = t->global_link;
-	  t->global_link = END_TSO_QUEUE;
-	  *prev = next;
-	  continue;
-      default:
-	  ;
+	  default:
+	      barf("traverse_weak_ptr_list: not WEAK");
+	  }
       }
+      
+      /* If we didn't make any changes, then we can go round and kill all
+       * the dead weak pointers.  The old_weak_ptr list is used as a list
+       * of pending finalizers later on.
+       */
+      if (flag == rtsFalse) {
+	  for (w = old_weak_ptr_list; w; w = w->link) {
+	      w->finalizer = evacuate(w->finalizer);
+	  }
 
-      if (tmp == NULL) {
-	  // not alive (yet): leave this thread on the old_all_threads list.
-	  prev = &(t->global_link);
-	  next = t->global_link;
-	  continue;
-      } 
-      else {
-	  // alive: move this thread onto the all_threads list.
-	  next = t->global_link;
-	  t->global_link = all_threads;
-	  all_threads  = t;
-	  *prev = next;
-	  break;
+	  // Next, move to the WeakThreads stage after fully
+	  // scavenging the finalizers we've just evacuated.
+	  weak_stage = WeakThreads;
       }
-    }
-  }
 
-  /* If we didn't make any changes, then we can go round and kill all
-   * the dead weak pointers.  The old_weak_ptr list is used as a list
-   * of pending finalizers later on.
-   */
-  if (flag == rtsFalse) {
-    cleanup_weak_ptr_list(&old_weak_ptr_list);
-    for (w = old_weak_ptr_list; w; w = w->link) {
-      w->finalizer = evacuate(w->finalizer);
-    }
+      return rtsTrue;
 
-    /* And resurrect any threads which were about to become garbage.
-     */
-    {
-      StgTSO *t, *tmp, *next;
-      for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
-	next = t->global_link;
-	(StgClosure *)tmp = evacuate((StgClosure *)t);
-	tmp->global_link = resurrected_threads;
-	resurrected_threads = tmp;
+  case WeakThreads:
+      /* Now deal with the all_threads list, which behaves somewhat like
+       * the weak ptr list.  If we discover any threads that are about to
+       * become garbage, we wake them up and administer an exception.
+       */
+      {
+	  StgTSO *t, *tmp, *next, **prev;
+	  
+	  prev = &old_all_threads;
+	  for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
+	      
+	      (StgClosure *)tmp = isAlive((StgClosure *)t);
+	      
+	      if (tmp != NULL) {
+		  t = tmp;
+	      }
+	      
+	      ASSERT(get_itbl(t)->type == TSO);
+	      switch (t->what_next) {
+	      case ThreadRelocated:
+		  next = t->link;
+		  *prev = next;
+		  continue;
+	      case ThreadKilled:
+	      case ThreadComplete:
+		  // finshed or died.  The thread might still be alive, but we
+		  // don't keep it on the all_threads list.  Don't forget to
+		  // stub out its global_link field.
+		  next = t->global_link;
+		  t->global_link = END_TSO_QUEUE;
+		  *prev = next;
+		  continue;
+	      default:
+		  ;
+	      }
+	      
+	      if (tmp == NULL) {
+		  // not alive (yet): leave this thread on the
+		  // old_all_threads list.
+		  prev = &(t->global_link);
+		  next = t->global_link;
+	      } 
+	      else {
+		  // alive: move this thread onto the all_threads list.
+		  next = t->global_link;
+		  t->global_link = all_threads;
+		  all_threads  = t;
+		  *prev = next;
+	      }
+	  }
       }
-    }
+      
+      /* And resurrect any threads which were about to become garbage.
+       */
+      {
+	  StgTSO *t, *tmp, *next;
+	  for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
+	      next = t->global_link;
+	      (StgClosure *)tmp = evacuate((StgClosure *)t);
+	      tmp->global_link = resurrected_threads;
+	      resurrected_threads = tmp;
+	  }
+      }
+      
+      weak_stage = WeakDone;  // *now* we're done,
+      return rtsTrue;         // but one more round of scavenging, please
 
-    weak_done = rtsTrue;
+  default:
+      barf("traverse_weak_ptr_list");
+      return rtsTrue;
   }
 
-  return rtsTrue;
 }
 
 /* -----------------------------------------------------------------------------
@@ -1084,23 +1317,18 @@ traverse_weak_ptr_list(void)
 
 
 static void
-cleanup_weak_ptr_list ( StgWeak **list )
+mark_weak_ptr_list ( StgWeak **list )
 {
   StgWeak *w, **last_w;
 
   last_w = list;
   for (w = *list; w; w = w->link) {
-
-    if (get_itbl(w)->type == EVACUATED) {
-      w = (StgWeak *)((StgEvacuated *)w)->evacuee;
-      *last_w = w;
-    }
-
-    if ((Bdescr((P_)w)->flags & BF_EVACUATED) == 0) {
+      // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
+      ASSERT(w->header.info == &stg_DEAD_WEAK_info 
+	     || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
       (StgClosure *)w = evacuate((StgClosure *)w);
       *last_w = w;
-    }
-    last_w = &(w->link);
+      last_w = &(w->link);
   }
 }
 
@@ -1121,25 +1349,37 @@ isAlive(StgClosure *p)
 
   while (1) {
 
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
     info = get_itbl(p);
 
-    /* ToDo: for static closures, check the static link field.
-     * Problem here is that we sometimes don't set the link field, eg.
-     * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
-     */
+    // ignore static closures 
+    //
+    // ToDo: for static closures, check the static link field.
+    // Problem here is that we sometimes don't set the link field, eg.
+    // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
+    //
+    if (!HEAP_ALLOCED(p)) {
+	return p;
+    }
 
-  loop:
-    bd = Bdescr((P_)p);
     // ignore closures in generations that we're not collecting. 
-    if (LOOKS_LIKE_STATIC(p) || bd->gen_no > N) {
+    bd = Bdescr((P_)p);
+    if (bd->gen_no > N) {
 	return p;
     }
-    // large objects have an evacuated flag
-    if ((bd->flags & BF_LARGE) && (bd->flags & BF_EVACUATED)) {
+
+    // if it's a pointer into to-space, then we're done
+    if (bd->flags & BF_EVACUATED) {
 	return p;
     }
+
+    // large objects use the evacuated flag
+    if (bd->flags & BF_LARGE) {
+	return NULL;
+    }
+
     // check the mark bit for compacted steps
-    if (bd->step->is_compacted && is_marked((P_)p,bd)) {
+    if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
 	return p;
     }
 
@@ -1161,8 +1401,9 @@ isAlive(StgClosure *p)
     case TSO:
       if (((StgTSO *)p)->what_next == ThreadRelocated) {
 	p = (StgClosure *)((StgTSO *)p)->link;
-	goto loop;
-      }
+	continue;
+      } 
+      return NULL;
 
     default:
       // dead. 
@@ -1177,41 +1418,26 @@ mark_root(StgClosure **root)
   *root = evacuate(*root);
 }
 
-static void
-addBlock(step *stp)
-{
-  bdescr *bd = allocBlock();
-  bd->gen_no = stp->gen_no;
-  bd->step = stp;
-
-  if (stp->gen_no <= N) {
-    bd->flags = BF_EVACUATED;
-  } else {
-    bd->flags = 0;
-  }
-
-  stp->hp_bd->free = stp->hp;
-  stp->hp_bd->link = bd;
-  stp->hp = bd->start;
-  stp->hpLim = stp->hp + BLOCK_SIZE_W;
-  stp->hp_bd = bd;
-  stp->n_to_blocks++;
-  new_blocks++;
-}
-
-
-static __inline__ void 
+STATIC_INLINE void 
 upd_evacuee(StgClosure *p, StgClosure *dest)
 {
-  p->header.info = &stg_EVACUATED_info;
-  ((StgEvacuated *)p)->evacuee = dest;
+    // Source object must be in from-space:
+    ASSERT((Bdescr((P_)p)->flags & BF_EVACUATED) == 0);
+    // not true: (ToDo: perhaps it should be)
+    // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
+    SET_INFO(p, &stg_EVACUATED_info);
+    ((StgEvacuated *)p)->evacuee = dest;
 }
 
 
-static __inline__ StgClosure *
+STATIC_INLINE StgClosure *
 copy(StgClosure *src, nat size, step *stp)
 {
   P_ to, from, dest;
+#ifdef PROFILING
+  // @LDV profiling
+  nat size_org = size;
+#endif
 
   TICK_GC_WORDS_COPIED(size);
   /* Find out where we're going, using the handy "to" pointer in 
@@ -1231,7 +1457,7 @@ copy(StgClosure *src, nat size, step *stp)
    * necessary.
    */
   if (stp->hp + size >= stp->hpLim) {
-    addBlock(stp);
+    gc_alloc_block(stp);
   }
 
   for(to = stp->hp, from = (P_)src; size>0; --size) {
@@ -1241,6 +1467,11 @@ copy(StgClosure *src, nat size, step *stp)
   dest = stp->hp;
   stp->hp = to;
   upd_evacuee(src,(StgClosure *)dest);
+#ifdef PROFILING
+  // We store the size of the just evacuated object in the LDV word so that
+  // the profiler can guess the position of the next object later.
+  SET_EVACUAEE_FOR_LDV(src, size_org);
+#endif
   return (StgClosure *)dest;
 }
 
@@ -1250,10 +1481,14 @@ copy(StgClosure *src, nat size, step *stp)
  */
 
 
-static __inline__ StgClosure *
+static StgClosure *
 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
 {
   P_ dest, to, from;
+#ifdef PROFILING
+  // @LDV profiling
+  nat size_to_copy_org = size_to_copy;
+#endif
 
   TICK_GC_WORDS_COPIED(size_to_copy);
   if (stp->gen_no < evac_gen) {
@@ -1265,7 +1500,7 @@ copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
   }
 
   if (stp->hp + size_to_reserve >= stp->hpLim) {
-    addBlock(stp);
+    gc_alloc_block(stp);
   }
 
   for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
@@ -1275,6 +1510,16 @@ copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
   dest = stp->hp;
   stp->hp += size_to_reserve;
   upd_evacuee(src,(StgClosure *)dest);
+#ifdef PROFILING
+  // We store the size of the just evacuated object in the LDV word so that
+  // the profiler can guess the position of the next object later.
+  // size_to_copy_org is wrong because the closure already occupies size_to_reserve
+  // words.
+  SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
+  // fill the slop
+  if (size_to_reserve - size_to_copy_org > 0)
+    FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org)); 
+#endif
   return (StgClosure *)dest;
 }
 
@@ -1283,23 +1528,24 @@ copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
    Evacuate a large object
 
    This just consists of removing the object from the (doubly-linked)
-   large_alloc_list, and linking it on to the (singly-linked)
-   new_large_objects list, from where it will be scavenged later.
+   step->large_objects list, and linking it on to the (singly-linked)
+   step->new_large_objects list, from where it will be scavenged later.
 
    Convention: bd->flags has BF_EVACUATED set for a large object
    that has been evacuated, or unset otherwise.
    -------------------------------------------------------------------------- */
 
 
-static inline void
+STATIC_INLINE void
 evacuate_large(StgPtr p)
 {
   bdescr *bd = Bdescr(p);
   step *stp;
 
-  // should point to the beginning of the block 
-  ASSERT(((W_)p & BLOCK_MASK) == 0);
-  
+  // object must be at the beginning of the block (or be a ByteArray)
+  ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
+	 (((W_)p & BLOCK_MASK) == 0));
+
   // already evacuated? 
   if (bd->flags & BF_EVACUATED) { 
     /* Don't forget to set the failed_to_evac flag if we didn't get
@@ -1349,7 +1595,6 @@ evacuate_large(StgPtr p)
    the promotion until the next GC.
    -------------------------------------------------------------------------- */
 
-
 static StgClosure *
 mkMutCons(StgClosure *ptr, generation *gen)
 {
@@ -1362,7 +1607,7 @@ mkMutCons(StgClosure *ptr, generation *gen)
    * necessary.
    */
   if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
-    addBlock(stp);
+    gc_alloc_block(stp);
   }
 
   q = (StgMutVar *)stp->hp;
@@ -1398,9 +1643,26 @@ mkMutCons(StgClosure *ptr, generation *gen)
    if  M <  evac_gen     set failed_to_evac flag to indicate that we
                          didn't manage to evacuate this object into evac_gen.
 
+
+   OPTIMISATION NOTES:
+
+   evacuate() is the single most important function performance-wise
+   in the GC.  Various things have been tried to speed it up, but as
+   far as I can tell the code generated by gcc 3.2 with -O2 is about
+   as good as it's going to get.  We pass the argument to evacuate()
+   in a register using the 'regparm' attribute (see the prototype for
+   evacuate() near the top of this file).
+
+   Changing evacuate() to take an (StgClosure **) rather than
+   returning the new pointer seems attractive, because we can avoid
+   writing back the pointer when it hasn't changed (eg. for a static
+   object, or an object in a generation > N).  However, I tried it and
+   it doesn't help.  One reason is that the (StgClosure **) pointer
+   gets spilled to the stack inside evacuate(), resulting in far more
+   extra reads/writes than we save.
    -------------------------------------------------------------------------- */
 
-static StgClosure *
+REGPARM1 static StgClosure *
 evacuate(StgClosure *q)
 {
   StgClosure *to;
@@ -1442,11 +1704,12 @@ loop:
     /* If the object is in a step that we're compacting, then we
      * need to use an alternative evacuate procedure.
      */
-    if (bd->step->is_compacted) {
+    if (bd->flags & BF_COMPACTED) {
 	if (!is_marked((P_)q,bd)) {
 	    mark((P_)q,bd);
 	    if (mark_stack_full()) {
-		barf("ToDo: mark stack full");
+		mark_stack_overflowed = rtsTrue;
+		reset_mark_stack();
 	    }
 	    push_mark_stack((P_)q);
 	}
@@ -1460,16 +1723,14 @@ loop:
 #endif
 
   // make sure the info pointer is into text space 
-  ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
-	       || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
   info = get_itbl(q);
   
   switch (info -> type) {
 
   case MUT_VAR:
   case MVAR:
-      to = copy(q,sizeW_fromITBL(info),stp);
-      return to;
+      return copy(q,sizeW_fromITBL(info),stp);
 
   case CONSTR_0_1:
   { 
@@ -1521,9 +1782,11 @@ loop:
   case WEAK:
   case FOREIGN:
   case STABLE_NAME:
-  case BCO:
     return copy(q,sizeW_fromITBL(info),stp);
 
+  case BCO:
+      return copy(q,bco_sizeW((StgBCO *)q),stp);
+
   case CAF_BLACKHOLE:
   case SE_CAF_BLACKHOLE:
   case SE_BLACKHOLE:
@@ -1536,139 +1799,32 @@ loop:
 
   case THUNK_SELECTOR:
     {
-      const StgInfoTable* selectee_info;
-      StgClosure* selectee = ((StgSelector*)q)->selectee;
-
-    selector_loop:
-      selectee_info = get_itbl(selectee);
-      switch (selectee_info->type) {
-      case CONSTR:
-      case CONSTR_1_0:
-      case CONSTR_0_1:
-      case CONSTR_2_0:
-      case CONSTR_1_1:
-      case CONSTR_0_2:
-      case CONSTR_STATIC:
-	{ 
-	  StgWord offset = info->layout.selector_offset;
-
-	  // check that the size is in range 
-	  ASSERT(offset < 
-		 (StgWord32)(selectee_info->layout.payload.ptrs + 
-		            selectee_info->layout.payload.nptrs));
+	StgClosure *p;
 
-	  // perform the selection! 
-	  q = selectee->payload[offset];
+	if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
+	    return copy(q,THUNK_SELECTOR_sizeW(),stp);
+	}
 
-	  /* if we're already in to-space, there's no need to continue
-	   * with the evacuation, just update the source address with
-	   * a pointer to the (evacuated) constructor field.
-	   */
-	  if (HEAP_ALLOCED(q)) {
-	    bdescr *bd = Bdescr((P_)q);
-	    if (bd->flags & BF_EVACUATED) {
-	      if (bd->gen_no < evac_gen) {
-		failed_to_evac = rtsTrue;
-		TICK_GC_FAILED_PROMOTION();
-	      }
-	      return q;
-	    }
-	  }
+	p = eval_thunk_selector(info->layout.selector_offset,
+				(StgSelector *)q);
 
-	  /* otherwise, carry on and evacuate this constructor field,
-	   * (but not the constructor itself)
-	   */
-	  goto loop;
+	if (p == NULL) {
+	    return copy(q,THUNK_SELECTOR_sizeW(),stp);
+	} else {
+	    // q is still BLACKHOLE'd.
+	    thunk_selector_depth++;
+	    p = evacuate(p);
+	    thunk_selector_depth--;
+	    upd_evacuee(q,p);
+#ifdef PROFILING
+	    // We store the size of the just evacuated object in the
+	    // LDV word so that the profiler can guess the position of
+	    // the next object later.
+	    SET_EVACUAEE_FOR_LDV(q, THUNK_SELECTOR_sizeW());
+#endif
+	    return p;
 	}
-
-      case IND:
-      case IND_STATIC:
-      case IND_PERM:
-      case IND_OLDGEN:
-      case IND_OLDGEN_PERM:
-	selectee = ((StgInd *)selectee)->indirectee;
-	goto selector_loop;
-
-      case EVACUATED:
-	selectee = ((StgEvacuated *)selectee)->evacuee;
-	goto selector_loop;
-
-      case THUNK_SELECTOR:
-#         if 0
-          /* Disabled 03 April 2001 by JRS; it seems to cause the GC (or
-             something) to go into an infinite loop when the nightly
-             stage2 compiles PrelTup.lhs. */
-
-	  /* we can't recurse indefinitely in evacuate(), so set a
-	   * limit on the number of times we can go around this
-	   * loop.
-	   */
-	  if (thunk_selector_depth < MAX_THUNK_SELECTOR_DEPTH) {
-	      bdescr *bd;
-	      bd = Bdescr((P_)selectee);
-	      if (!bd->flags & BF_EVACUATED) {
-		  thunk_selector_depth++;
-		  selectee = evacuate(selectee);
-		  thunk_selector_depth--;
-		  goto selector_loop;
-	      }
-	  }
-	  // otherwise, fall through... 
-#         endif
-
-      case AP_UPD:
-      case THUNK:
-      case THUNK_1_0:
-      case THUNK_0_1:
-      case THUNK_2_0:
-      case THUNK_1_1:
-      case THUNK_0_2:
-      case THUNK_STATIC:
-      case CAF_BLACKHOLE:
-      case SE_CAF_BLACKHOLE:
-      case SE_BLACKHOLE:
-      case BLACKHOLE:
-      case BLACKHOLE_BQ:
-	// not evaluated yet 
-	break;
-
-#if defined(PAR)
-	// a copy of the top-level cases below 
-      case RBH: // cf. BLACKHOLE_BQ
-  	{
-  	  //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
-  	  to = copy(q,BLACKHOLE_sizeW(),stp); 
-  	  //ToDo: derive size etc from reverted IP
-  	  //to = copy(q,size,stp);
-  	  // recordMutable((StgMutClosure *)to);
-  	  return to;
-  	}
-    
-      case BLOCKED_FETCH:
-  	ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
-  	to = copy(q,sizeofW(StgBlockedFetch),stp);
-  	return to;
-
-# ifdef DIST    
-      case REMOTE_REF:
-# endif
-      case FETCH_ME:
-  	ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
-  	to = copy(q,sizeofW(StgFetchMe),stp);
-  	return to;
-    
-      case FETCH_ME_BQ:
-  	ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
-  	to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
-  	return to;
-#endif
-
-      default:
-	barf("evacuate: THUNK_SELECTOR: strange selectee %d",
-	     (int)(selectee_info->type));
-      }
-    }
-    return copy(q,THUNK_SELECTOR_sizeW(),stp);
+    }
 
   case IND:
   case IND_OLDGEN:
@@ -1677,7 +1833,7 @@ loop:
     goto loop;
 
   case THUNK_STATIC:
-    if (info->srt_len > 0 && major_gc && 
+    if (info->srt_bitmap != 0 && major_gc && 
 	THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
       THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
       static_objects = (StgClosure *)q;
@@ -1685,7 +1841,7 @@ loop:
     return q;
 
   case FUN_STATIC:
-    if (info->srt_len > 0 && major_gc && 
+    if (info->srt_bitmap != 0 && major_gc && 
 	FUN_STATIC_LINK((StgClosure *)q) == NULL) {
       FUN_STATIC_LINK((StgClosure *)q) = static_objects;
       static_objects = (StgClosure *)q;
@@ -1729,17 +1885,19 @@ loop:
   case UPDATE_FRAME:
   case STOP_FRAME:
   case CATCH_FRAME:
-  case SEQ_FRAME:
+  case CATCH_STM_FRAME:
+  case CATCH_RETRY_FRAME:
+  case ATOMICALLY_FRAME:
     // shouldn't see these 
     barf("evacuate: stack frame at %p\n", q);
 
-  case AP_UPD:
   case PAP:
-    /* PAPs and AP_UPDs are special - the payload is a copy of a chunk
-     * of stack, tagging and all.
-     */
+  case AP:
       return copy(q,pap_sizeW((StgPAP*)q),stp);
 
+  case AP_STACK:
+      return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
+
   case EVACUATED:
     /* Already evacuated, just return the forwarding address.
      * HOWEVER: if the requested destination generation (evac_gen) is
@@ -1750,8 +1908,7 @@ loop:
      */
     if (evac_gen > 0) {		// optimisation 
       StgClosure *p = ((StgEvacuated*)q)->evacuee;
-      if (Bdescr((P_)p)->gen_no < evac_gen) {
-	IF_DEBUG(gc, belch("@@ evacuate: evac of EVACUATED node %p failed!", p));
+      if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
 	failed_to_evac = rtsTrue;
 	TICK_GC_FAILED_PROMOTION();
       }
@@ -1782,8 +1939,18 @@ loop:
        * list it contains.  
        */
       {
-	  StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),stp);
+	  StgTSO *new_tso;
+	  StgPtr p, q;
+
+	  new_tso = (StgTSO *)copyPart((StgClosure *)tso,
+				       tso_sizeW(tso),
+				       sizeofW(StgTSO), stp);
 	  move_TSO(tso, new_tso);
+	  for (p = tso->sp, q = new_tso->sp;
+	       p < tso->stack+tso->stack_size;) {
+	      *q++ = *p++;
+	  }
+	  
 	  return (StgClosure *)new_tso;
       }
     }
@@ -1796,7 +1963,7 @@ loop:
       //ToDo: derive size etc from reverted IP
       //to = copy(q,size,stp);
       IF_DEBUG(gc,
-	       belch("@@ evacuate: RBH %p (%s) to %p (%s)",
+	       debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)",
 		     q, info_type(q), to, info_type(to)));
       return to;
     }
@@ -1805,7 +1972,7 @@ loop:
     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
     to = copy(q,sizeofW(StgBlockedFetch),stp);
     IF_DEBUG(gc,
-	     belch("@@ evacuate: %p (%s) to %p (%s)",
+	     debugBelch("@@ evacuate: %p (%s) to %p (%s)",
 		   q, info_type(q), to, info_type(to)));
     return to;
 
@@ -1816,7 +1983,7 @@ loop:
     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
     to = copy(q,sizeofW(StgFetchMe),stp);
     IF_DEBUG(gc,
-	     belch("@@ evacuate: %p (%s) to %p (%s)",
+	     debugBelch("@@ evacuate: %p (%s) to %p (%s)",
 		   q, info_type(q), to, info_type(to)));
     return to;
 
@@ -1824,11 +1991,23 @@ loop:
     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
     IF_DEBUG(gc,
-	     belch("@@ evacuate: %p (%s) to %p (%s)",
+	     debugBelch("@@ evacuate: %p (%s) to %p (%s)",
 		   q, info_type(q), to, info_type(to)));
     return to;
 #endif
 
+  case TREC_HEADER: 
+    return copy(q,sizeofW(StgTRecHeader),stp);
+
+  case TVAR_WAIT_QUEUE:
+    return copy(q,sizeofW(StgTVarWaitQueue),stp);
+
+  case TVAR:
+    return copy(q,sizeofW(StgTVar),stp);
+    
+  case TREC_CHUNK:
+    return copy(q,sizeofW(StgTRecChunk),stp);
+
   default:
     barf("evacuate: strange closure type %d", (int)(info->type));
   }
@@ -1837,108 +2016,333 @@ loop:
 }
 
 /* -----------------------------------------------------------------------------
-   move_TSO is called to update the TSO structure after it has been
-   moved from one place to another.
+   Evaluate a THUNK_SELECTOR if possible.
+
+   returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
+   a closure pointer if we evaluated it and this is the result.  Note
+   that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
+   reducing it to HNF, just that we have eliminated the selection.
+   The result might be another thunk, or even another THUNK_SELECTOR.
+
+   If the return value is non-NULL, the original selector thunk has
+   been BLACKHOLE'd, and should be updated with an indirection or a
+   forwarding pointer.  If the return value is NULL, then the selector
+   thunk is unchanged.
    -------------------------------------------------------------------------- */
 
-void
-move_TSO(StgTSO *src, StgTSO *dest)
+static inline rtsBool
+is_to_space ( StgClosure *p )
 {
-    ptrdiff_t diff;
+    bdescr *bd;
+
+    bd = Bdescr((StgPtr)p);
+    if (HEAP_ALLOCED(p) &&
+	((bd->flags & BF_EVACUATED) 
+	 || ((bd->flags & BF_COMPACTED) &&
+	     is_marked((P_)p,bd)))) {
+	return rtsTrue;
+    } else {
+	return rtsFalse;
+    }
+}    
 
-    // relocate the stack pointers... 
-    diff = (StgPtr)dest - (StgPtr)src; // In *words* 
-    dest->sp = (StgPtr)dest->sp + diff;
-    dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
+static StgClosure *
+eval_thunk_selector( nat field, StgSelector * p )
+{
+    StgInfoTable *info;
+    const StgInfoTable *info_ptr;
+    StgClosure *selectee;
+    
+    selectee = p->selectee;
 
-    relocate_stack(dest, diff);
-}
+    // Save the real info pointer (NOTE: not the same as get_itbl()).
+    info_ptr = p->header.info;
 
-/* -----------------------------------------------------------------------------
-   relocate_stack is called to update the linkage between
-   UPDATE_FRAMEs (and SEQ_FRAMEs etc.) when a stack is moved from one
-   place to another.
-   -------------------------------------------------------------------------- */
+    // If the THUNK_SELECTOR is in a generation that we are not
+    // collecting, then bail out early.  We won't be able to save any
+    // space in any case, and updating with an indirection is trickier
+    // in an old gen.
+    if (Bdescr((StgPtr)p)->gen_no > N) {
+	return NULL;
+    }
 
-StgTSO *
-relocate_stack(StgTSO *dest, ptrdiff_t diff)
-{
-  StgUpdateFrame *su;
-  StgCatchFrame  *cf;
-  StgSeqFrame    *sf;
+    // BLACKHOLE the selector thunk, since it is now under evaluation.
+    // This is important to stop us going into an infinite loop if
+    // this selector thunk eventually refers to itself.
+    SET_INFO(p,&stg_BLACKHOLE_info);
+
+selector_loop:
+
+    // We don't want to end up in to-space, because this causes
+    // problems when the GC later tries to evacuate the result of
+    // eval_thunk_selector().  There are various ways this could
+    // happen:
+    //
+    // 1. following an IND_STATIC
+    //
+    // 2. when the old generation is compacted, the mark phase updates
+    //    from-space pointers to be to-space pointers, and we can't
+    //    reliably tell which we're following (eg. from an IND_STATIC).
+    // 
+    // 3. compacting GC again: if we're looking at a constructor in
+    //    the compacted generation, it might point directly to objects
+    //    in to-space.  We must bale out here, otherwise doing the selection
+    //    will result in a to-space pointer being returned.
+    //
+    //  (1) is dealt with using a BF_EVACUATED test on the
+    //  selectee. (2) and (3): we can tell if we're looking at an
+    //  object in the compacted generation that might point to
+    //  to-space objects by testing that (a) it is BF_COMPACTED, (b)
+    //  the compacted generation is being collected, and (c) the
+    //  object is marked.  Only a marked object may have pointers that
+    //  point to to-space objects, because that happens when
+    //  scavenging.
+    //
+    //  The to-space test is now embodied in the in_to_space() inline
+    //  function, as it is re-used below.
+    //
+    if (is_to_space(selectee)) {
+	goto bale_out;
+    }
 
-  su = dest->su;
+    info = get_itbl(selectee);
+    switch (info->type) {
+      case CONSTR:
+      case CONSTR_1_0:
+      case CONSTR_0_1:
+      case CONSTR_2_0:
+      case CONSTR_1_1:
+      case CONSTR_0_2:
+      case CONSTR_STATIC:
+      case CONSTR_NOCAF_STATIC:
+	  // check that the size is in range 
+	  ASSERT(field <  (StgWord32)(info->layout.payload.ptrs + 
+				      info->layout.payload.nptrs));
+	  
+	  // Select the right field from the constructor, and check
+	  // that the result isn't in to-space.  It might be in
+	  // to-space if, for example, this constructor contains
+	  // pointers to younger-gen objects (and is on the mut-once
+	  // list).
+	  //
+	  { 
+	      StgClosure *q;
+	      q = selectee->payload[field];
+	      if (is_to_space(q)) {
+		  goto bale_out;
+	      } else {
+		  return q;
+	      }
+	  }
 
-  while ((P_)su < dest->stack + dest->stack_size) {
-    switch (get_itbl(su)->type) {
-   
-      // GCC actually manages to common up these three cases! 
+      case IND:
+      case IND_PERM:
+      case IND_OLDGEN:
+      case IND_OLDGEN_PERM:
+      case IND_STATIC:
+	  selectee = ((StgInd *)selectee)->indirectee;
+	  goto selector_loop;
 
-    case UPDATE_FRAME:
-      su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
-      su = su->link;
-      continue;
+      case EVACUATED:
+	  // We don't follow pointers into to-space; the constructor
+	  // has already been evacuated, so we won't save any space
+	  // leaks by evaluating this selector thunk anyhow.
+	  break;
 
-    case CATCH_FRAME:
-      cf = (StgCatchFrame *)su;
-      cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
-      su = cf->link;
-      continue;
+      case THUNK_SELECTOR:
+      {
+	  StgClosure *val;
 
-    case SEQ_FRAME:
-      sf = (StgSeqFrame *)su;
-      sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
-      su = sf->link;
-      continue;
+	  // check that we don't recurse too much, re-using the
+	  // depth bound also used in evacuate().
+	  thunk_selector_depth++;
+	  if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
+	      break;
+	  }
 
-    case STOP_FRAME:
-      // all done! 
-      break;
+	  val = eval_thunk_selector(info->layout.selector_offset, 
+				    (StgSelector *)selectee);
 
-    default:
-      barf("relocate_stack %d", (int)(get_itbl(su)->type));
+	  thunk_selector_depth--;
+
+	  if (val == NULL) { 
+	      break;
+	  } else {
+	      // We evaluated this selector thunk, so update it with
+	      // an indirection.  NOTE: we don't use UPD_IND here,
+	      // because we are guaranteed that p is in a generation
+	      // that we are collecting, and we never want to put the
+	      // indirection on a mutable list.
+#ifdef PROFILING
+	      // For the purposes of LDV profiling, we have destroyed
+	      // the original selector thunk.
+	      SET_INFO(p, info_ptr);
+	      LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
+#endif
+	      ((StgInd *)selectee)->indirectee = val;
+	      SET_INFO(selectee,&stg_IND_info);
+
+	      // For the purposes of LDV profiling, we have created an
+	      // indirection.
+	      LDV_RECORD_CREATE(selectee);
+
+	      selectee = val;
+	      goto selector_loop;
+	  }
+      }
+
+      case AP:
+      case AP_STACK:
+      case THUNK:
+      case THUNK_1_0:
+      case THUNK_0_1:
+      case THUNK_2_0:
+      case THUNK_1_1:
+      case THUNK_0_2:
+      case THUNK_STATIC:
+      case CAF_BLACKHOLE:
+      case SE_CAF_BLACKHOLE:
+      case SE_BLACKHOLE:
+      case BLACKHOLE:
+      case BLACKHOLE_BQ:
+#if defined(PAR)
+      case RBH:
+      case BLOCKED_FETCH:
+# ifdef DIST    
+      case REMOTE_REF:
+# endif
+      case FETCH_ME:
+      case FETCH_ME_BQ:
+#endif
+	  // not evaluated yet 
+	  break;
+    
+      default:
+	barf("eval_thunk_selector: strange selectee %d",
+	     (int)(info->type));
     }
-    break;
-  }
 
-  return dest;
+bale_out:
+    // We didn't manage to evaluate this thunk; restore the old info pointer
+    SET_INFO(p, info_ptr);
+    return NULL;
 }
 
+/* -----------------------------------------------------------------------------
+   move_TSO is called to update the TSO structure after it has been
+   moved from one place to another.
+   -------------------------------------------------------------------------- */
+
+void
+move_TSO (StgTSO *src, StgTSO *dest)
+{
+    ptrdiff_t diff;
+
+    // relocate the stack pointer... 
+    diff = (StgPtr)dest - (StgPtr)src; // In *words* 
+    dest->sp = (StgPtr)dest->sp + diff;
+}
 
+/* Similar to scavenge_large_bitmap(), but we don't write back the
+ * pointers we get back from evacuate().
+ */
+static void
+scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
+{
+    nat i, b, size;
+    StgWord bitmap;
+    StgClosure **p;
+    
+    b = 0;
+    bitmap = large_srt->l.bitmap[b];
+    size   = (nat)large_srt->l.size;
+    p      = (StgClosure **)large_srt->srt;
+    for (i = 0; i < size; ) {
+	if ((bitmap & 1) != 0) {
+	    evacuate(*p);
+	}
+	i++;
+	p++;
+	if (i % BITS_IN(W_) == 0) {
+	    b++;
+	    bitmap = large_srt->l.bitmap[b];
+	} else {
+	    bitmap = bitmap >> 1;
+	}
+    }
+}
 
-static inline void
-scavenge_srt(const StgInfoTable *info)
+/* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
+ * srt field in the info table.  That's ok, because we'll
+ * never dereference it.
+ */
+STATIC_INLINE void
+scavenge_srt (StgClosure **srt, nat srt_bitmap)
 {
-  StgClosure **srt, **srt_end;
+  nat bitmap;
+  StgClosure **p;
 
-  /* evacuate the SRT.  If srt_len is zero, then there isn't an
-   * srt field in the info table.  That's ok, because we'll
-   * never dereference it.
-   */
-  srt = (StgClosure **)(info->srt);
-  srt_end = srt + info->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.
-    */
+  bitmap = srt_bitmap;
+  p = srt;
+
+  if (bitmap == (StgHalfWord)(-1)) {  
+      scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
+      return;
+  }
+
+  while (bitmap != 0) {
+      if ((bitmap & 1) != 0) {
 #ifdef ENABLE_WIN32_DLL_SUPPORT
-    if ( (unsigned long)(*srt) & 0x1 ) {
-       evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
-    } else {
-       evacuate(*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.
+	  if ( (unsigned long)(*srt) & 0x1 ) {
+	      evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
+	  } else {
+	      evacuate(*p);
+	  }
 #else
-       evacuate(*srt);
+	  evacuate(*p);
 #endif
+      }
+      p++;
+      bitmap = bitmap >> 1;
   }
 }
 
+
+STATIC_INLINE void
+scavenge_thunk_srt(const StgInfoTable *info)
+{
+    StgThunkInfoTable *thunk_info;
+
+    thunk_info = itbl_to_thunk_itbl(info);
+    scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
+}
+
+STATIC_INLINE void
+scavenge_fun_srt(const StgInfoTable *info)
+{
+    StgFunInfoTable *fun_info;
+
+    fun_info = itbl_to_fun_itbl(info);
+    scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
+}
+
+STATIC_INLINE void
+scavenge_ret_srt(const StgInfoTable *info)
+{
+    StgRetInfoTable *ret_info;
+
+    ret_info = itbl_to_ret_itbl(info);
+    scavenge_srt((StgClosure **)GET_SRT(ret_info), ret_info->i.srt_bitmap);
+}
+
 /* -----------------------------------------------------------------------------
    Scavenge a TSO.
    -------------------------------------------------------------------------- */
@@ -1946,24 +2350,111 @@ scavenge_srt(const StgInfoTable *info)
 static void
 scavengeTSO (StgTSO *tso)
 {
-  // chase the link field for any TSOs on the same queue 
-  (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
-  if (   tso->why_blocked == BlockedOnMVar
-	 || tso->why_blocked == BlockedOnBlackHole
-	 || tso->why_blocked == BlockedOnException
+    // chase the link field for any TSOs on the same queue 
+    (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
+    if (   tso->why_blocked == BlockedOnMVar
+	|| tso->why_blocked == BlockedOnBlackHole
+	|| tso->why_blocked == BlockedOnException
 #if defined(PAR)
-	 || tso->why_blocked == BlockedOnGA
-	 || tso->why_blocked == BlockedOnGA_NoSend
+	|| tso->why_blocked == BlockedOnGA
+	|| tso->why_blocked == BlockedOnGA_NoSend
 #endif
-	 ) {
-    tso->block_info.closure = evacuate(tso->block_info.closure);
-  }
-  if ( tso->blocked_exceptions != NULL ) {
-    tso->blocked_exceptions = 
-      (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
-  }
-  // scavenge this thread's stack 
-  scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+	) {
+	tso->block_info.closure = evacuate(tso->block_info.closure);
+    }
+    if ( tso->blocked_exceptions != NULL ) {
+	tso->blocked_exceptions = 
+	    (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
+    }
+    
+    // scavange current transaction record
+    (StgClosure *)tso->trec = evacuate((StgClosure *)tso->trec);
+    
+    // scavenge this thread's stack 
+    scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+}
+
+/* -----------------------------------------------------------------------------
+   Blocks of function args occur on the stack (at the top) and
+   in PAPs.
+   -------------------------------------------------------------------------- */
+
+STATIC_INLINE StgPtr
+scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
+{
+    StgPtr p;
+    StgWord bitmap;
+    nat size;
+
+    p = (StgPtr)args;
+    switch (fun_info->f.fun_type) {
+    case ARG_GEN:
+	bitmap = BITMAP_BITS(fun_info->f.bitmap);
+	size = BITMAP_SIZE(fun_info->f.bitmap);
+	goto small_bitmap;
+    case ARG_GEN_BIG:
+	size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+	scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
+	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]);
+    small_bitmap:
+	while (size > 0) {
+	    if ((bitmap & 1) == 0) {
+		(StgClosure *)*p = evacuate((StgClosure *)*p);
+	    }
+	    p++;
+	    bitmap = bitmap >> 1;
+	    size--;
+	}
+	break;
+    }
+    return p;
+}
+
+STATIC_INLINE StgPtr
+scavenge_PAP (StgPAP *pap)
+{
+    StgPtr p;
+    StgWord bitmap, size;
+    StgFunInfoTable *fun_info;
+
+    pap->fun = evacuate(pap->fun);
+    fun_info = get_fun_itbl(pap->fun);
+    ASSERT(fun_info->i.type != PAP);
+
+    p = (StgPtr)pap->payload;
+    size = pap->n_args;
+
+    switch (fun_info->f.fun_type) {
+    case ARG_GEN:
+	bitmap = BITMAP_BITS(fun_info->f.bitmap);
+	goto small_bitmap;
+    case ARG_GEN_BIG:
+	scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
+	p += size;
+	break;
+    case ARG_BCO:
+	scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
+	p += size;
+	break;
+    default:
+	bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+    small_bitmap:
+	size = pap->n_args;
+	while (size > 0) {
+	    if ((bitmap & 1) == 0) {
+		(StgClosure *)*p = evacuate((StgClosure *)*p);
+	    }
+	    p++;
+	    bitmap = bitmap >> 1;
+	    size--;
+	}
+	break;
+    }
+    return p;
 }
 
 /* -----------------------------------------------------------------------------
@@ -2005,12 +2496,14 @@ scavenge(step *stp)
       continue;
     }
 
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
     info = get_itbl((StgClosure *)p);
-    ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
     
+    ASSERT(thunk_selector_depth == 0);
+
     q = p;
     switch (info->type) {
-	
+
     case MVAR:
 	/* treat MVars specially, because we don't want to evacuate the
 	 * mut_link field in the middle of the closure.
@@ -2028,9 +2521,15 @@ scavenge(step *stp)
 	break;
     }
 
-    case THUNK_2_0:
     case FUN_2_0:
-	scavenge_srt(info);
+	scavenge_fun_srt(info);
+	((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
+	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+	p += sizeofW(StgHeader) + 2;
+	break;
+
+    case THUNK_2_0:
+	scavenge_thunk_srt(info);
     case CONSTR_2_0:
 	((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
 	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
@@ -2038,54 +2537,66 @@ scavenge(step *stp)
 	break;
 	
     case THUNK_1_0:
-	scavenge_srt(info);
+	scavenge_thunk_srt(info);
 	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
 	p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE 
 	break;
 	
     case FUN_1_0:
-	scavenge_srt(info);
+	scavenge_fun_srt(info);
     case CONSTR_1_0:
 	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
 	p += sizeofW(StgHeader) + 1;
 	break;
 	
     case THUNK_0_1:
-	scavenge_srt(info);
+	scavenge_thunk_srt(info);
 	p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE 
 	break;
 	
     case FUN_0_1:
-	scavenge_srt(info);
+	scavenge_fun_srt(info);
     case CONSTR_0_1:
 	p += sizeofW(StgHeader) + 1;
 	break;
 	
     case THUNK_0_2:
+	scavenge_thunk_srt(info);
+	p += sizeofW(StgHeader) + 2;
+	break;
+	
     case FUN_0_2:
-	scavenge_srt(info);
+	scavenge_fun_srt(info);
     case CONSTR_0_2:
 	p += sizeofW(StgHeader) + 2;
 	break;
 	
     case THUNK_1_1:
+	scavenge_thunk_srt(info);
+	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+	p += sizeofW(StgHeader) + 2;
+	break;
+
     case FUN_1_1:
-	scavenge_srt(info);
+	scavenge_fun_srt(info);
     case CONSTR_1_1:
 	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
 	p += sizeofW(StgHeader) + 2;
 	break;
 	
     case FUN:
+	scavenge_fun_srt(info);
+	goto gen_obj;
+
     case THUNK:
-	scavenge_srt(info);
+	scavenge_thunk_srt(info);
 	// fall through 
 	
+    gen_obj:
     case CONSTR:
     case WEAK:
     case FOREIGN:
     case STABLE_NAME:
-    case BCO:
     {
 	StgPtr end;
 
@@ -2097,10 +2608,32 @@ scavenge(step *stp)
 	break;
     }
 
+    case BCO: {
+	StgBCO *bco = (StgBCO *)p;
+	(StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
+	(StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
+	(StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
+	(StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
+	p += bco_sizeW(bco);
+	break;
+    }
+
     case IND_PERM:
-	if (stp->gen_no != 0) {
-	    SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
-	}
+      if (stp->gen->no != 0) {
+#ifdef PROFILING
+        // @LDV profiling
+        // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an 
+        // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
+        LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
+#endif        
+        // 
+        // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
+        //
+	SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
+
+        // We pretend that p has just been created.
+        LDV_RECORD_CREATE((StgClosure *)p);
+      }
 	// fall through 
     case IND_OLDGEN_PERM:
 	((StgIndOldGen *)p)->indirectee = 
@@ -2153,20 +2686,22 @@ scavenge(step *stp)
 	break;
     }
 
-    case AP_UPD: // same as PAPs 
-    case PAP:
-	/* Treat a PAP just like a section of stack, not forgetting to
-	 * evacuate the function pointer too...
-	 */
-    { 
-	StgPAP* pap = (StgPAP *)p;
+    // A chunk of stack saved in a heap object
+    case AP_STACK:
+    {
+	StgAP_STACK *ap = (StgAP_STACK *)p;
 
-	pap->fun = evacuate(pap->fun);
-	scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
-	p += pap_sizeW(pap);
+	ap->fun = evacuate(ap->fun);
+	scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
+	p = (StgPtr)ap->payload + ap->size;
 	break;
     }
-      
+
+    case PAP:
+    case AP:
+	p = scavenge_PAP((StgPAP *)p);
+	break;
+
     case ARR_WORDS:
 	// nothing to follow 
 	p += arr_words_sizeW((StgArrWords *)p);
@@ -2193,6 +2728,11 @@ scavenge(step *stp)
     {
 	StgPtr next;
 
+	// Set the mut_link field to NULL, so that we will put this
+	// array back on the mutable list if it is subsequently thawed
+	// by unsafeThaw#.
+	((StgMutArrPtrs*)p)->mut_link = NULL;
+
 	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 	    (StgClosure *)*p = evacuate((StgClosure *)*p);
@@ -2230,7 +2770,7 @@ scavenge(step *stp)
 	recordMutable((StgMutClosure *)to);
 	failed_to_evac = rtsFalse;  // mutable anyhow.
 	IF_DEBUG(gc,
-		 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
+		 debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
 		       p, info_type(p), (StgClosure *)rbh->blocking_queue));
 	// ToDo: use size of reverted closure here!
 	p += BLACKHOLE_sizeW(); 
@@ -2251,7 +2791,7 @@ scavenge(step *stp)
 	    recordMutable((StgMutClosure *)bf);
 	}
 	IF_DEBUG(gc,
-		 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
+		 debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
 		       bf, info_type((StgClosure *)bf), 
 		       bf->node, info_type(bf->node)));
 	p += sizeofW(StgBlockedFetch);
@@ -2275,15 +2815,74 @@ scavenge(step *stp)
 	    recordMutable((StgMutClosure *)fmbq);
 	}
 	IF_DEBUG(gc,
-		 belch("@@ scavenge: %p (%s) exciting, isn't it",
+		 debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
 		       p, info_type((StgClosure *)p)));
 	p += sizeofW(StgFetchMeBlockingQueue);
 	break;
     }
 #endif
 
-    default:
-	barf("scavenge: unimplemented/strange closure type %d @ %p", 
+    case TVAR_WAIT_QUEUE:
+      {
+	StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
+	evac_gen = 0;
+	(StgClosure *)wq->waiting_tso = evacuate((StgClosure*)wq->waiting_tso);
+	(StgClosure *)wq->next_queue_entry = evacuate((StgClosure*)wq->next_queue_entry);
+	(StgClosure *)wq->prev_queue_entry = evacuate((StgClosure*)wq->prev_queue_entry);
+	evac_gen = saved_evac_gen;
+	recordMutable((StgMutClosure *)wq);
+	failed_to_evac = rtsFalse; // mutable
+	p += sizeofW(StgTVarWaitQueue);
+	break;
+      }
+
+    case TVAR:
+      {
+	StgTVar *tvar = ((StgTVar *) p);
+	evac_gen = 0;
+	(StgClosure *)tvar->current_value = evacuate((StgClosure*)tvar->current_value);
+	(StgClosure *)tvar->first_wait_queue_entry = evacuate((StgClosure*)tvar->first_wait_queue_entry);
+	evac_gen = saved_evac_gen;
+	recordMutable((StgMutClosure *)tvar);
+	failed_to_evac = rtsFalse; // mutable
+	p += sizeofW(StgTVar);
+	break;
+      }
+
+    case TREC_HEADER:
+      {
+        StgTRecHeader *trec = ((StgTRecHeader *) p);
+        evac_gen = 0;
+	(StgClosure *)trec->enclosing_trec = evacuate((StgClosure*)trec->enclosing_trec);
+	(StgClosure *)trec->current_chunk = evacuate((StgClosure*)trec->current_chunk);
+	evac_gen = saved_evac_gen;
+	recordMutable((StgMutClosure *)trec);
+	failed_to_evac = rtsFalse; // mutable
+	p += sizeofW(StgTRecHeader);
+        break;
+      }
+
+    case TREC_CHUNK:
+      {
+	StgWord i;
+	StgTRecChunk *tc = ((StgTRecChunk *) p);
+	TRecEntry *e = &(tc -> entries[0]);
+	evac_gen = 0;
+	(StgClosure *)tc->prev_chunk = evacuate((StgClosure*)tc->prev_chunk);
+	for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
+	  (StgClosure *)e->tvar = evacuate((StgClosure*)e->tvar);
+	  (StgClosure *)e->expected_value = evacuate((StgClosure*)e->expected_value);
+	  (StgClosure *)e->new_value = evacuate((StgClosure*)e->new_value);
+	}
+	evac_gen = saved_evac_gen;
+	recordMutable((StgMutClosure *)tc);
+	failed_to_evac = rtsFalse; // mutable
+	p += sizeofW(StgTRecChunk);
+	break;
+      }
+
+    default:
+	barf("scavenge: unimplemented/strange closure type %d @ %p", 
 	     info->type, p);
     }
 
@@ -2312,19 +2911,21 @@ scavenge(step *stp)
 static void
 scavenge_mark_stack(void)
 {
-    StgPtr p;
+    StgPtr p, q;
     StgInfoTable *info;
     nat saved_evac_gen;
 
     evac_gen = oldest_gen->no;
     saved_evac_gen = evac_gen;
 
+linear_scan:
     while (!mark_stack_empty()) {
 	p = pop_mark_stack();
 
+	ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 	info = get_itbl((StgClosure *)p);
-	ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
 	
+	q = p;
 	switch (info->type) {
 	    
 	case MVAR:
@@ -2343,8 +2944,13 @@ scavenge_mark_stack(void)
 	}
 
 	case FUN_2_0:
+	    scavenge_fun_srt(info);
+	    ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
+	    ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+	    break;
+
 	case THUNK_2_0:
-	    scavenge_srt(info);
+	    scavenge_thunk_srt(info);
 	case CONSTR_2_0:
 	    ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
 	    ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
@@ -2352,9 +2958,13 @@ scavenge_mark_stack(void)
 	
 	case FUN_1_0:
 	case FUN_1_1:
+	    scavenge_fun_srt(info);
+	    ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+	    break;
+
 	case THUNK_1_0:
 	case THUNK_1_1:
-	    scavenge_srt(info);
+	    scavenge_thunk_srt(info);
 	case CONSTR_1_0:
 	case CONSTR_1_1:
 	    ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
@@ -2362,23 +2972,31 @@ scavenge_mark_stack(void)
 	
 	case FUN_0_1:
 	case FUN_0_2:
+	    scavenge_fun_srt(info);
+	    break;
+
 	case THUNK_0_1:
 	case THUNK_0_2:
-	    scavenge_srt(info);
+	    scavenge_thunk_srt(info);
+	    break;
+
 	case CONSTR_0_1:
 	case CONSTR_0_2:
 	    break;
 	
 	case FUN:
+	    scavenge_fun_srt(info);
+	    goto gen_obj;
+
 	case THUNK:
-	    scavenge_srt(info);
+	    scavenge_thunk_srt(info);
 	    // fall through 
 	
+	gen_obj:
 	case CONSTR:
 	case WEAK:
 	case FOREIGN:
 	case STABLE_NAME:
-	case BCO:
 	{
 	    StgPtr end;
 	    
@@ -2389,6 +3007,15 @@ scavenge_mark_stack(void)
 	    break;
 	}
 
+	case BCO: {
+	    StgBCO *bco = (StgBCO *)p;
+	    (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
+	    (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
+	    (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
+	    (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
+	    break;
+	}
+
 	case IND_PERM:
 	    // don't need to do anything here: the only possible case
 	    // is that we're in a 1-space compacting collector, with
@@ -2440,18 +3067,20 @@ scavenge_mark_stack(void)
 	    break;
 	}
 
-	case AP_UPD: // same as PAPs 
-	case PAP:
-	    /* Treat a PAP just like a section of stack, not forgetting to
-	     * evacuate the function pointer too...
-	     */
-	{ 
-	    StgPAP* pap = (StgPAP *)p;
+	// A chunk of stack saved in a heap object
+	case AP_STACK:
+	{
+	    StgAP_STACK *ap = (StgAP_STACK *)p;
 	    
-	    pap->fun = evacuate(pap->fun);
-	    scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
+	    ap->fun = evacuate(ap->fun);
+	    scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
 	    break;
 	}
+
+	case PAP:
+	case AP:
+	    scavenge_PAP((StgPAP *)p);
+	    break;
       
 	case MUT_ARR_PTRS:
 	    // follow everything 
@@ -2473,6 +3102,11 @@ scavenge_mark_stack(void)
 	{
 	    StgPtr next;
 	    
+	    // Set the mut_link field to NULL, so that we will put this
+	    // array on the mutable list if it is subsequently thawed
+	    // by unsafeThaw#.
+	    ((StgMutArrPtrs*)p)->mut_link = NULL;
+
 	    next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 	    for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 		(StgClosure *)*p = evacuate((StgClosure *)*p);
@@ -2504,7 +3138,7 @@ scavenge_mark_stack(void)
 	    recordMutable((StgMutClosure *)rbh);
 	    failed_to_evac = rtsFalse;  // mutable anyhow.
 	    IF_DEBUG(gc,
-		     belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
+		     debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
 			   p, info_type(p), (StgClosure *)rbh->blocking_queue));
 	    break;
 	}
@@ -2523,7 +3157,7 @@ scavenge_mark_stack(void)
 		recordMutable((StgMutClosure *)bf);
 	    }
 	    IF_DEBUG(gc,
-		     belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
+		     debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
 			   bf, info_type((StgClosure *)bf), 
 			   bf->node, info_type(bf->node)));
 	    break;
@@ -2545,11 +3179,66 @@ scavenge_mark_stack(void)
 		recordMutable((StgMutClosure *)fmbq);
 	    }
 	    IF_DEBUG(gc,
-		     belch("@@ scavenge: %p (%s) exciting, isn't it",
+		     debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
 			   p, info_type((StgClosure *)p)));
 	    break;
 	}
-#endif
+#endif // PAR
+
+	case TVAR_WAIT_QUEUE:
+	  {
+	    StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
+	    evac_gen = 0;
+	    (StgClosure *)wq->waiting_tso = evacuate((StgClosure*)wq->waiting_tso);
+	    (StgClosure *)wq->next_queue_entry = evacuate((StgClosure*)wq->next_queue_entry);
+	    (StgClosure *)wq->prev_queue_entry = evacuate((StgClosure*)wq->prev_queue_entry);
+	    evac_gen = saved_evac_gen;
+	    recordMutable((StgMutClosure *)wq);
+	    failed_to_evac = rtsFalse; // mutable
+	    break;
+	  }
+	  
+	case TVAR:
+	  {
+	    StgTVar *tvar = ((StgTVar *) p);
+	    evac_gen = 0;
+	    (StgClosure *)tvar->current_value = evacuate((StgClosure*)tvar->current_value);
+	    (StgClosure *)tvar->first_wait_queue_entry = evacuate((StgClosure*)tvar->first_wait_queue_entry);
+	    evac_gen = saved_evac_gen;
+	    recordMutable((StgMutClosure *)tvar);
+	    failed_to_evac = rtsFalse; // mutable
+	    break;
+	  }
+	  
+	case TREC_CHUNK:
+	  {
+	    StgWord i;
+	    StgTRecChunk *tc = ((StgTRecChunk *) p);
+	    TRecEntry *e = &(tc -> entries[0]);
+	    evac_gen = 0;
+	    (StgClosure *)tc->prev_chunk = evacuate((StgClosure*)tc->prev_chunk);
+	    for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
+	      (StgClosure *)e->tvar = evacuate((StgClosure*)e->tvar);
+	      (StgClosure *)e->expected_value = evacuate((StgClosure*)e->expected_value);
+	      (StgClosure *)e->new_value = evacuate((StgClosure*)e->new_value);
+	    }
+	    evac_gen = saved_evac_gen;
+	    recordMutable((StgMutClosure *)tc);
+	    failed_to_evac = rtsFalse; // mutable
+	    break;
+	  }
+
+	case TREC_HEADER:
+	  {
+	    StgTRecHeader *trec = ((StgTRecHeader *) p);
+	    evac_gen = 0;
+	    (StgClosure *)trec->enclosing_trec = evacuate((StgClosure*)trec->enclosing_trec);
+	    (StgClosure *)trec->current_chunk = evacuate((StgClosure*)trec->current_chunk);
+	    evac_gen = saved_evac_gen;
+	    recordMutable((StgMutClosure *)trec);
+	    failed_to_evac = rtsFalse; // mutable
+	    break;
+	  }
 
 	default:
 	    barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p", 
@@ -2558,11 +3247,52 @@ scavenge_mark_stack(void)
 
 	if (failed_to_evac) {
 	    failed_to_evac = rtsFalse;
-	    mkMutCons((StgClosure *)p, &generations[evac_gen]);
+	    mkMutCons((StgClosure *)q, &generations[evac_gen]);
 	}
+	
+	// mark the next bit to indicate "scavenged"
+	mark(q+1, Bdescr(q));
 
     } // while (!mark_stack_empty())
-}    
+
+    // start a new linear scan if the mark stack overflowed at some point
+    if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
+	IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan"));
+	mark_stack_overflowed = rtsFalse;
+	oldgen_scan_bd = oldest_gen->steps[0].blocks;
+	oldgen_scan = oldgen_scan_bd->start;
+    }
+
+    if (oldgen_scan_bd) {
+	// push a new thing on the mark stack
+    loop:
+	// find a closure that is marked but not scavenged, and start
+	// from there.
+	while (oldgen_scan < oldgen_scan_bd->free 
+	       && !is_marked(oldgen_scan,oldgen_scan_bd)) {
+	    oldgen_scan++;
+	}
+
+	if (oldgen_scan < oldgen_scan_bd->free) {
+
+	    // already scavenged?
+	    if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
+		oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
+		goto loop;
+	    }
+	    push_mark_stack(oldgen_scan);
+	    // ToDo: bump the linear scan by the actual size of the object
+	    oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
+	    goto linear_scan;
+	}
+
+	oldgen_scan_bd = oldgen_scan_bd->link;
+	if (oldgen_scan_bd != NULL) {
+	    oldgen_scan = oldgen_scan_bd->start;
+	    goto loop;
+	}
+    }
+}
 
 /* -----------------------------------------------------------------------------
    Scavenge one object.
@@ -2573,104 +3303,140 @@ scavenge_mark_stack(void)
    -------------------------------------------------------------------------- */
 
 static rtsBool
-scavenge_one(StgClosure *p)
+scavenge_one(StgPtr p)
 {
-  const StgInfoTable *info;
-  rtsBool no_luck;
-
-  ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
-	       || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
-
-  info = get_itbl(p);
-
-  switch (info -> type) {
+    const StgInfoTable *info;
+    nat saved_evac_gen = evac_gen;
+    rtsBool no_luck;
+    
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+    info = get_itbl((StgClosure *)p);
+    
+    switch (info->type) {
+	
+    case FUN:
+    case FUN_1_0:			// hardly worth specialising these guys
+    case FUN_0_1:
+    case FUN_1_1:
+    case FUN_0_2:
+    case FUN_2_0:
+    case THUNK:
+    case THUNK_1_0:
+    case THUNK_0_1:
+    case THUNK_1_1:
+    case THUNK_0_2:
+    case THUNK_2_0:
+    case CONSTR:
+    case CONSTR_1_0:
+    case CONSTR_0_1:
+    case CONSTR_1_1:
+    case CONSTR_0_2:
+    case CONSTR_2_0:
+    case WEAK:
+    case FOREIGN:
+    case IND_PERM:
+    case IND_OLDGEN_PERM:
+    {
+	StgPtr q, end;
+	
+	end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
+	for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
+	    (StgClosure *)*q = evacuate((StgClosure *)*q);
+	}
+	break;
+    }
+    
+    case CAF_BLACKHOLE:
+    case SE_CAF_BLACKHOLE:
+    case SE_BLACKHOLE:
+    case BLACKHOLE:
+	break;
+	
+    case THUNK_SELECTOR:
+    { 
+	StgSelector *s = (StgSelector *)p;
+	s->selectee = evacuate(s->selectee);
+	break;
+    }
+    
+    case ARR_WORDS:
+	// nothing to follow 
+	break;
 
-  case FUN:
-  case FUN_1_0:			// hardly worth specialising these guys
-  case FUN_0_1:
-  case FUN_1_1:
-  case FUN_0_2:
-  case FUN_2_0:
-  case THUNK:
-  case THUNK_1_0:
-  case THUNK_0_1:
-  case THUNK_1_1:
-  case THUNK_0_2:
-  case THUNK_2_0:
-  case CONSTR:
-  case CONSTR_1_0:
-  case CONSTR_0_1:
-  case CONSTR_1_1:
-  case CONSTR_0_2:
-  case CONSTR_2_0:
-  case WEAK:
-  case FOREIGN:
-  case IND_PERM:
-  case IND_OLDGEN_PERM:
+    case MUT_ARR_PTRS:
     {
-      StgPtr q, end;
+	// follow everything 
+	StgPtr next;
       
-      end = (P_)p->payload + info->layout.payload.ptrs;
-      for (q = (P_)p->payload; q < end; q++) {
-	(StgClosure *)*q = evacuate((StgClosure *)*q);
-      }
-      break;
+	evac_gen = 0;		// repeatedly mutable 
+	recordMutable((StgMutClosure *)p);
+	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+	    (StgClosure *)*p = evacuate((StgClosure *)*p);
+	}
+	evac_gen = saved_evac_gen;
+	failed_to_evac = rtsFalse;
+	break;
     }
 
-  case CAF_BLACKHOLE:
-  case SE_CAF_BLACKHOLE:
-  case SE_BLACKHOLE:
-  case BLACKHOLE:
-      break;
+    case MUT_ARR_PTRS_FROZEN:
+    {
+	// follow everything 
+	StgPtr next;
+      
+	// Set the mut_link field to NULL, so that we will put this
+	// array on the mutable list if it is subsequently thawed
+	// by unsafeThaw#.
+	((StgMutArrPtrs*)p)->mut_link = NULL;
 
-  case THUNK_SELECTOR:
-    { 
-      StgSelector *s = (StgSelector *)p;
-      s->selectee = evacuate(s->selectee);
-      break;
+	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+	    (StgClosure *)*p = evacuate((StgClosure *)*p);
+	}
+	break;
     }
-    
-  case AP_UPD: /* same as PAPs */
-  case PAP:
-    /* Treat a PAP just like a section of stack, not forgetting to
-     * evacuate the function pointer too...
-     */
-    { 
-      StgPAP* pap = (StgPAP *)p;
+
+    case TSO:
+    {
+	StgTSO *tso = (StgTSO *)p;
       
-      pap->fun = evacuate(pap->fun);
-      scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
-      break;
+	evac_gen = 0;		// repeatedly mutable 
+	scavengeTSO(tso);
+	recordMutable((StgMutClosure *)tso);
+	evac_gen = saved_evac_gen;
+	failed_to_evac = rtsFalse;
+	break;
     }
+  
+    case AP_STACK:
+    {
+	StgAP_STACK *ap = (StgAP_STACK *)p;
 
-  case IND_OLDGEN:
-      /* This might happen if for instance a MUT_CONS was pointing to a
-       * THUNK which has since been updated.  The IND_OLDGEN will
-       * be on the mutable list anyway, so we don't need to do anything
-       * here.
-       */
-      break;
+	ap->fun = evacuate(ap->fun);
+	scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
+	p = (StgPtr)ap->payload + ap->size;
+	break;
+    }
 
-  case MUT_ARR_PTRS_FROZEN:
-      {
-	  // follow everything 
-	  StgPtr q, next;
+    case PAP:
+    case AP:
+	p = scavenge_PAP((StgPAP *)p);
+	break;
 
-	  q = (StgPtr)p;
-	  next = q + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	  for (q = (P_)((StgMutArrPtrs *)p)->payload; q < next; q++) {
-	      (StgClosure *)*q = evacuate((StgClosure *)*q);
-	  }
-	  break;
-      }
+    case IND_OLDGEN:
+	// This might happen if for instance a MUT_CONS was pointing to a
+	// THUNK which has since been updated.  The IND_OLDGEN will
+	// be on the mutable list anyway, so we don't need to do anything
+	// here.
+	break;
 
-  default:
-    barf("scavenge_one: strange object %d", (int)(info->type));
-  }    
+    default:
+	barf("scavenge_one: strange object %d", (int)(info->type));
+    }    
 
-  no_luck = failed_to_evac;
-  failed_to_evac = rtsFalse;
-  return (no_luck);
+    no_luck = failed_to_evac;
+    failed_to_evac = rtsFalse;
+    return (no_luck);
 }
 
 /* -----------------------------------------------------------------------------
@@ -2696,10 +3462,7 @@ scavenge_mut_once_list(generation *gen)
 
   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
 
-    // make sure the info pointer is into text space 
-    ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
-		 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
-    
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
     info = get_itbl(p);
     /*
     if (info->type==RBH)
@@ -2738,7 +3501,7 @@ scavenge_mut_once_list(generation *gen)
 	} else {
 	  size = gen->steps[0].scan - start;
 	}
-	fprintf(stderr,"evac IND_OLDGEN: %ld bytes\n", size * sizeof(W_));
+	debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
       }
 #endif
 
@@ -2762,23 +3525,21 @@ scavenge_mut_once_list(generation *gen)
 	p->mut_link = NULL;
       }
       continue;
-      
+
     case MUT_CONS:
 	/* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
 	 * it from the mutable list if possible by promoting whatever it
 	 * points to.
 	 */
-	scavenge_one((StgClosure *)((StgMutVar *)p)->var);
-	if (failed_to_evac == rtsTrue) {
+	if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
 	    /* didn't manage to promote everything, so put the
 	     * MUT_CONS back on the list.
 	     */
-	    failed_to_evac = rtsFalse;
 	    p->mut_link = new_list;
 	    new_list = p;
 	}
 	continue;
-      
+
     default:
       // shouldn't have anything else on the mutables list 
       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
@@ -2803,10 +3564,7 @@ scavenge_mutable_list(generation *gen)
 
   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
 
-    // make sure the info pointer is into text space 
-    ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
-		 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
-    
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
     info = get_itbl(p);
     /*
     if (info->type==RBH)
@@ -2828,12 +3586,34 @@ scavenge_mutable_list(generation *gen)
 	continue;
       }
       
+      // Happens if a MUT_ARR_PTRS in the old generation is frozen
+    case MUT_ARR_PTRS_FROZEN:
+      {
+	StgPtr end, q;
+	
+	evac_gen = gen->no;
+	end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+	for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
+	  (StgClosure *)*q = evacuate((StgClosure *)*q);
+	}
+	evac_gen = 0;
+	// Set the mut_link field to NULL, so that we will put this
+	// array back on the mutable list if it is subsequently thawed
+	// by unsafeThaw#.
+	p->mut_link = NULL;
+	if (failed_to_evac) {
+	    failed_to_evac = rtsFalse;
+	    mkMutCons((StgClosure *)p, gen);
+	}
+	continue;
+      }
+	
     case MUT_VAR:
 	((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
 	p->mut_link = gen->mut_list;
 	gen->mut_list = p;
 	continue;
-      
+
     case MVAR:
       {
 	StgMVar *mvar = (StgMVar *)p;
@@ -2950,9 +3730,56 @@ scavenge_mutable_list(generation *gen)
       }
 #endif
 
-    default:
-      // shouldn't have anything else on the mutables list 
-      barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
+    case TVAR_WAIT_QUEUE:
+      {
+	StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
+	(StgClosure *)wq->waiting_tso = evacuate((StgClosure*)wq->waiting_tso);
+	(StgClosure *)wq->next_queue_entry = evacuate((StgClosure*)wq->next_queue_entry);
+	(StgClosure *)wq->prev_queue_entry = evacuate((StgClosure*)wq->prev_queue_entry);
+	p->mut_link = gen->mut_list;
+	gen->mut_list = p;
+	continue;
+      }
+
+    case TVAR:
+      {
+	StgTVar *tvar = ((StgTVar *) p);
+	(StgClosure *)tvar->current_value = evacuate((StgClosure*)tvar->current_value);
+	(StgClosure *)tvar->first_wait_queue_entry = evacuate((StgClosure*)tvar->first_wait_queue_entry);
+	p->mut_link = gen->mut_list;
+	gen->mut_list = p;
+	continue;
+      }
+
+    case TREC_CHUNK:
+      {
+	StgWord i;
+	StgTRecChunk *tc = ((StgTRecChunk *) p);
+	TRecEntry *e = &(tc -> entries[0]);
+	(StgClosure *)tc->prev_chunk = evacuate((StgClosure*)tc->prev_chunk);
+	for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
+	  (StgClosure *)e->tvar = evacuate((StgClosure*)e->tvar);
+	  (StgClosure *)e->expected_value = evacuate((StgClosure*)e->expected_value);
+	  (StgClosure *)e->new_value = evacuate((StgClosure*)e->new_value);
+	}
+	p->mut_link = gen->mut_list;
+	gen->mut_list = p;
+	continue;
+      }
+
+    case TREC_HEADER:
+      {
+	StgTRecHeader *trec = ((StgTRecHeader *) p);
+	(StgClosure *)trec->enclosing_trec = evacuate((StgClosure*)trec->enclosing_trec);
+	(StgClosure *)trec->current_chunk = evacuate((StgClosure*)trec->current_chunk);
+	p->mut_link = gen->mut_list;
+	gen->mut_list = p;
+	continue;
+      }
+
+    default:
+      // shouldn't have anything else on the mutables list 
+      barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
     }
   }
 }
@@ -2972,14 +3799,13 @@ scavenge_static(void)
      list... */
   while (p != END_OF_STATIC_LIST) {
 
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
     info = get_itbl(p);
     /*
     if (info->type==RBH)
       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
     */
     // make sure the info pointer is into text space 
-    ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
-		 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
     
     /* Take this object *off* the static_objects list,
      * and put it on the scavenged_static_objects list.
@@ -3002,7 +3828,7 @@ scavenge_static(void)
 	 */
 	if (failed_to_evac) {
 	  failed_to_evac = rtsFalse;
-	  scavenged_static_objects = STATIC_LINK(info,p);
+	  scavenged_static_objects = IND_STATIC_LINK(p);
 	  ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
 	  oldest_gen->mut_once_list = (StgMutClosure *)ind;
 	}
@@ -3010,8 +3836,11 @@ scavenge_static(void)
       }
       
     case THUNK_STATIC:
+      scavenge_thunk_srt(info);
+      break;
+
     case FUN_STATIC:
-      scavenge_srt(info);
+      scavenge_fun_srt(info);
       break;
       
     case CONSTR_STATIC:
@@ -3041,200 +3870,166 @@ scavenge_static(void)
 }
 
 /* -----------------------------------------------------------------------------
+   scavenge a chunk of memory described by a bitmap
+   -------------------------------------------------------------------------- */
+
+static void
+scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
+{
+    nat i, b;
+    StgWord bitmap;
+    
+    b = 0;
+    bitmap = large_bitmap->bitmap[b];
+    for (i = 0; i < size; ) {
+	if ((bitmap & 1) == 0) {
+	    (StgClosure *)*p = evacuate((StgClosure *)*p);
+	}
+	i++;
+	p++;
+	if (i % BITS_IN(W_) == 0) {
+	    b++;
+	    bitmap = large_bitmap->bitmap[b];
+	} else {
+	    bitmap = bitmap >> 1;
+	}
+    }
+}
+
+STATIC_INLINE StgPtr
+scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
+{
+    while (size > 0) {
+	if ((bitmap & 1) == 0) {
+	    (StgClosure *)*p = evacuate((StgClosure *)*p);
+	}
+	p++;
+	bitmap = bitmap >> 1;
+	size--;
+    }
+    return p;
+}
+
+/* -----------------------------------------------------------------------------
    scavenge_stack walks over a section of stack and evacuates all the
    objects pointed to by it.  We can use the same code for walking
-   PAPs, since these are just sections of copied stack.
+   AP_STACK_UPDs, since these are just sections of copied stack.
    -------------------------------------------------------------------------- */
 
+
 static void
 scavenge_stack(StgPtr p, StgPtr stack_end)
 {
-  StgPtr q;
-  const StgInfoTable* info;
+  const StgRetInfoTable* info;
   StgWord bitmap;
+  nat size;
 
-  //IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
+  //IF_DEBUG(sanity, debugBelch("  scavenging stack between %p and %p", p, stack_end));
 
   /* 
    * Each time around this loop, we are looking at a chunk of stack
-   * that starts with either a pending argument section or an 
-   * activation record. 
+   * that starts with an activation record. 
    */
 
   while (p < stack_end) {
-    q = *(P_ *)p;
-
-    // If we've got a tag, skip over that many words on the stack 
-    if (IS_ARG_TAG((W_)q)) {
-      p += ARG_SIZE(q);
-      p++; continue;
-    }
-     
-    /* Is q a pointer to a closure?
-     */
-    if (! LOOKS_LIKE_GHC_INFO(q) ) {
-#ifdef DEBUG
-      if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  // Is it a static closure? 
-	ASSERT(closure_STATIC((StgClosure *)q));
-      }
-      // otherwise, must be a pointer into the allocation space. 
-#endif
-
-      (StgClosure *)*p = evacuate((StgClosure *)q);
-      p++; 
-      continue;
-    }
+    info  = get_ret_itbl((StgClosure *)p);
       
-    /* 
-     * Otherwise, q must be the info pointer of an activation
-     * record.  All activation records have 'bitmap' style layout
-     * info.
-     */
-    info  = get_itbl((StgClosure *)p);
-      
-    switch (info->type) {
+    switch (info->i.type) {
 	
-      // Dynamic bitmap: the mask is stored on the stack 
-    case RET_DYN:
-      bitmap = ((StgRetDyn *)p)->liveness;
-      p      = (P_)&((StgRetDyn *)p)->payload[0];
-      goto small_bitmap;
-
-      // probably a slow-entry point return address: 
-    case FUN:
-    case FUN_STATIC:
-      {
-#if 0	
-	StgPtr old_p = p;
-	p++; p++; 
-	IF_DEBUG(sanity, 
-		 belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
-		       old_p, p, old_p+1));
-#else
-      p++; // what if FHS!=1 !? -- HWL 
-#endif
-      goto follow_srt;
-      }
-
-      /* Specialised code for update frames, since they're so common.
-       * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
-       * or BLACKHOLE_BQ, so just inline the code to evacuate it here.  
-       */
     case UPDATE_FRAME:
-      {
-	StgUpdateFrame *frame = (StgUpdateFrame *)p;
-
+	((StgUpdateFrame *)p)->updatee 
+	    = evacuate(((StgUpdateFrame *)p)->updatee);
 	p += sizeofW(StgUpdateFrame);
-
-#ifndef not_yet
-	frame->updatee = evacuate(frame->updatee);
 	continue;
-#else // specialised code for update frames, not sure if it's worth it.
-	StgClosure *to;
-	nat type = get_itbl(frame->updatee)->type;
-
-	if (type == EVACUATED) {
-	  frame->updatee = evacuate(frame->updatee);
-	  continue;
-	} else {
-	  bdescr *bd = Bdescr((P_)frame->updatee);
-	  step *stp;
-	  if (bd->gen_no > N) { 
-	    if (bd->gen_no < evac_gen) {
-	      failed_to_evac = rtsTrue;
-	    }
-	    continue;
-	  }
-
-	  // Don't promote blackholes 
-	  stp = bd->step;
-	  if (!(stp->gen_no == 0 && 
-		stp->no != 0 &&
-		stp->no == stp->gen->n_steps-1)) {
-	    stp = stp->to;
-	  }
-
-	  switch (type) {
-	  case BLACKHOLE:
-	  case CAF_BLACKHOLE:
-	    to = copyPart(frame->updatee, BLACKHOLE_sizeW(), 
-			  sizeofW(StgHeader), stp);
-	    frame->updatee = to;
-	    continue;
-	  case BLACKHOLE_BQ:
-	    to = copy(frame->updatee, BLACKHOLE_sizeW(), stp);
-	    frame->updatee = to;
-	    recordMutable((StgMutClosure *)to);
-	    continue;
-	  default:
-            /* will never be SE_{,CAF_}BLACKHOLE, since we
-               don't push an update frame for single-entry thunks.  KSW 1999-01. */
-	    barf("scavenge_stack: UPDATE_FRAME updatee");
-	  }
-	}
-#endif
-      }
 
       // small bitmap (< 32 entries, or 64 on a 64-bit machine) 
+    case CATCH_STM_FRAME:
+    case CATCH_RETRY_FRAME:
+    case ATOMICALLY_FRAME:
     case STOP_FRAME:
     case CATCH_FRAME:
-    case SEQ_FRAME:
-    case RET_BCO:
     case RET_SMALL:
     case RET_VEC_SMALL:
-      bitmap = info->layout.bitmap;
-      p++;
-      // this assumes that the payload starts immediately after the info-ptr 
-    small_bitmap:
-      while (bitmap != 0) {
-	if ((bitmap & 1) == 0) {
-	  (StgClosure *)*p = evacuate((StgClosure *)*p);
-	}
+	bitmap = BITMAP_BITS(info->i.layout.bitmap);
+	size   = BITMAP_SIZE(info->i.layout.bitmap);
+	// NOTE: the payload starts immediately after the info-ptr, we
+	// don't have an StgHeader in the same sense as a heap closure.
 	p++;
-	bitmap = bitmap >> 1;
-      }
-      
+	p = scavenge_small_bitmap(p, size, bitmap);
+
     follow_srt:
-      scavenge_srt(info);
-      continue;
+	scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
+	continue;
+
+    case RET_BCO: {
+	StgBCO *bco;
+	nat size;
+
+	p++;
+	(StgClosure *)*p = evacuate((StgClosure *)*p);
+	bco = (StgBCO *)*p;
+	p++;
+	size = BCO_BITMAP_SIZE(bco);
+	scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
+	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;
+    {
+	nat size;
 
-	large_bitmap = info->layout.large_bitmap;
+	size = GET_LARGE_BITMAP(&info->i)->size;
 	p++;
+	scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
+	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 + BITS_IN(W_);
-	  while (bitmap != 0) {
-	    if ((bitmap & 1) == 0) {
-	      (StgClosure *)*p = evacuate((StgClosure *)*p);
-	    }
+      // Dynamic bitmap: the mask is stored on the stack, and
+      // there are a number of non-pointers followed by a number
+      // of pointers above the bitmapped area.  (see StgMacros.h,
+      // HEAP_CHK_GEN).
+    case RET_DYN:
+    {
+	StgWord dyn;
+	dyn = ((StgRetDyn *)p)->liveness;
+
+	// traverse the bitmap first
+	bitmap = RET_DYN_LIVENESS(dyn);
+	p      = (P_)&((StgRetDyn *)p)->payload[0];
+	size   = RET_DYN_BITMAP_SIZE;
+	p = scavenge_small_bitmap(p, size, bitmap);
+
+	// skip over the non-ptr words
+	p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
+	
+	// follow the ptr words
+	for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
+	    (StgClosure *)*p = evacuate((StgClosure *)*p);
 	    p++;
-	    bitmap = bitmap >> 1;
-	  }
-	  if (i+1 < large_bitmap->size) {
-	    while (p < q) {
-	      (StgClosure *)*p = evacuate((StgClosure *)*p);
-	      p++;
-	    }
-	  }
 	}
+	continue;
+    }
 
-	// and don't forget to follow the SRT 
+    case RET_FUN:
+    {
+	StgRetFun *ret_fun = (StgRetFun *)p;
+	StgFunInfoTable *fun_info;
+
+	ret_fun->fun = evacuate(ret_fun->fun);
+ 	fun_info = get_fun_itbl(ret_fun->fun);
+	p = scavenge_arg_block(fun_info, ret_fun->payload);
 	goto follow_srt;
-      }
+    }
 
     default:
-      barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
+	barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
     }
-  }
+  }		     
 }
 
 /*-----------------------------------------------------------------------------
@@ -3250,9 +4045,7 @@ static void
 scavenge_large(step *stp)
 {
   bdescr *bd;
-  StgPtr p, q;
-  const StgInfoTable* info;
-  nat saved_evac_gen = evac_gen; // used for temporarily changing evac_gen 
+  StgPtr p;
 
   bd = stp->new_large_objects;
 
@@ -3266,73 +4059,12 @@ scavenge_large(step *stp)
     stp->new_large_objects = bd->link;
     dbl_link_onto(bd, &stp->scavenged_large_objects);
 
-    p = bd->start;
-    info  = get_itbl((StgClosure *)p);
-
-    // only certain objects can be "large"... 
-    q = p;
-    switch (info->type) {
-
-    case ARR_WORDS:
-	// nothing to follow 
-	break;
-
-    case MUT_ARR_PTRS:
-    {
-	// follow everything 
-	StgPtr next;
-	
-	evac_gen = 0;		// repeatedly mutable 
-	recordMutable((StgMutClosure *)p);
-	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-	    (StgClosure *)*p = evacuate((StgClosure *)*p);
-	}
-	evac_gen = saved_evac_gen;
-	failed_to_evac = rtsFalse;
-	break;
-    }
-
-    case MUT_ARR_PTRS_FROZEN:
-      {
-	  // follow everything 
-	  StgPtr next;
-	  
-	  next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	  for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-	      (StgClosure *)*p = evacuate((StgClosure *)*p);
-	  }
-	  break;
-      }
-
-    case TSO:
-    {
-	StgTSO *tso = (StgTSO *)p;
-
-	evac_gen = 0;		// repeatedly mutable 
-	scavengeTSO(tso);
-	recordMutable((StgMutClosure *)tso);
-	evac_gen = saved_evac_gen;
-	failed_to_evac = rtsFalse;
-	break;
-    }
-
-    case AP_UPD:
-    case PAP:
-      { 
-	StgPAP* pap = (StgPAP *)p;
-	pap->fun = evacuate(pap->fun);
-	scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
-	break;
-      }
-
-    default:
-      barf("scavenge_large: unknown/strange object  %d", (int)(info->type));
-    }
+    // update the block count in this step.
+    stp->n_scavenged_large_blocks += bd->blocks;
 
-    if (failed_to_evac) {
-	failed_to_evac = rtsFalse;
-	mkMutCons((StgClosure *)q, &generations[evac_gen]);
+    p = bd->start;
+    if (scavenge_one(p)) {
+	mkMutCons((StgClosure *)p, stp->gen);
     }
   }
 }
@@ -3387,7 +4119,7 @@ revertCAFs( void )
     for (c = (StgIndStatic *)caf_list; c != NULL; 
 	 c = (StgIndStatic *)c->static_link) 
     {
-	c->header.info = c->saved_info;
+	SET_INFO(c, c->saved_info);
 	c->saved_info = NULL;
 	// could, but not necessary: c->static_link = NULL; 
     }
@@ -3395,15 +4127,14 @@ revertCAFs( void )
 }
 
 void
-scavengeCAFs( void )
+markCAFs( evac_fn evac )
 {
     StgIndStatic *c;
 
-    evac_gen = 0;
     for (c = (StgIndStatic *)caf_list; c != NULL; 
 	 c = (StgIndStatic *)c->static_link) 
     {
-	c->indirectee = evacuate(c->indirectee);
+	evac(&c->indirectee);
     }
 }
 
@@ -3440,7 +4171,7 @@ gcCAFs(void)
     ASSERT(info->type == IND_STATIC);
 
     if (STATIC_LINK(info,p) == NULL) {
-      IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04lx\n", (long)p));
+      IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p));
       // black hole it 
       SET_INFO(p,&stg_BLACKHOLE_info);
       p = STATIC_LINK2(info,p);
@@ -3454,7 +4185,7 @@ gcCAFs(void)
 
   }
 
-  //  fprintf(stderr, "%d CAFs live\n", i); 
+  //  debugBelch("%d CAFs live", i); 
 }
 #endif
 
@@ -3470,55 +4201,61 @@ gcCAFs(void)
 static void
 threadLazyBlackHole(StgTSO *tso)
 {
-  StgUpdateFrame *update_frame;
-  StgBlockingQueue *bh;
-  StgPtr stack_end;
-
-  stack_end = &tso->stack[tso->stack_size];
-  update_frame = tso->su;
-
-  while (1) {
-    switch (get_itbl(update_frame)->type) {
-
-    case CATCH_FRAME:
-      update_frame = ((StgCatchFrame *)update_frame)->link;
-      break;
-
-    case UPDATE_FRAME:
-      bh = (StgBlockingQueue *)update_frame->updatee;
-
-      /* if the thunk is already blackholed, it means we've also
-       * already blackholed the rest of the thunks on this stack,
-       * so we can stop early.
-       *
-       * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
-       * don't interfere with this optimisation.
-       */
-      if (bh->header.info == &stg_BLACKHOLE_info) {
-	return;
-      }
+    StgClosure *frame;
+    StgRetInfoTable *info;
+    StgBlockingQueue *bh;
+    StgPtr stack_end;
+    
+    stack_end = &tso->stack[tso->stack_size];
+    
+    frame = (StgClosure *)tso->sp;
 
-      if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
-	  bh->header.info != &stg_CAF_BLACKHOLE_info) {
+    while (1) {
+	info = get_ret_itbl(frame);
+	
+	switch (info->i.type) {
+	    
+	case UPDATE_FRAME:
+	    bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
+	    
+	    /* if the thunk is already blackholed, it means we've also
+	     * already blackholed the rest of the thunks on this stack,
+	     * so we can stop early.
+	     *
+	     * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
+	     * don't interfere with this optimisation.
+	     */
+	    if (bh->header.info == &stg_BLACKHOLE_info) {
+		return;
+	    }
+	    
+	    if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
+		bh->header.info != &stg_CAF_BLACKHOLE_info) {
 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
-        fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
+		debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh);
 #endif
-	SET_INFO(bh,&stg_BLACKHOLE_info);
-      }
-
-      update_frame = update_frame->link;
-      break;
-
-    case SEQ_FRAME:
-      update_frame = ((StgSeqFrame *)update_frame)->link;
-      break;
+#ifdef PROFILING
+		// @LDV profiling
+		// We pretend that bh is now dead.
+		LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
+#endif
+		SET_INFO(bh,&stg_BLACKHOLE_info);
 
-    case STOP_FRAME:
-      return;
-    default:
-      barf("threadPaused");
+		// We pretend that bh has just been created.
+		LDV_RECORD_CREATE(bh);
+	    }
+	    
+	    frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
+	    break;
+	    
+	case STOP_FRAME:
+	    return;
+	    
+	    // normal stack frames; do nothing except advance the pointer
+	default:
+	    (StgPtr)frame += stack_frame_sizeW(frame);
+	}
     }
-  }
 }
 
 
@@ -3530,264 +4267,203 @@ threadLazyBlackHole(StgTSO *tso)
  *
  * -------------------------------------------------------------------------- */
 
+struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
+
 static void
 threadSqueezeStack(StgTSO *tso)
 {
-  lnat displacement = 0;
-  StgUpdateFrame *frame;
-  StgUpdateFrame *next_frame;		        // Temporally next 
-  StgUpdateFrame *prev_frame;			// Temporally previous 
-  StgPtr bottom;
-  rtsBool prev_was_update_frame;
-#if DEBUG
-  StgUpdateFrame *top_frame;
-  nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
-      bhs=0, squeezes=0;
-  void printObj( StgClosure *obj ); // from Printer.c
+    StgPtr frame;
+    rtsBool prev_was_update_frame;
+    StgClosure *updatee = NULL;
+    StgPtr bottom;
+    StgRetInfoTable *info;
+    StgWord current_gap_size;
+    struct stack_gap *gap;
 
-  top_frame  = tso->su;
-#endif
-  
-  bottom = &(tso->stack[tso->stack_size]);
-  frame  = tso->su;
+    // Stage 1: 
+    //    Traverse the stack upwards, replacing adjacent update frames
+    //    with a single update frame and a "stack gap".  A stack gap
+    //    contains two values: the size of the gap, and the distance
+    //    to the next gap (or the stack top).
 
-  /* There must be at least one frame, namely the STOP_FRAME.
-   */
-  ASSERT((P_)frame < bottom);
+    bottom = &(tso->stack[tso->stack_size]);
 
-  /* Walk down the stack, reversing the links between frames so that
-   * we can walk back up as we squeeze from the bottom.  Note that
-   * next_frame and prev_frame refer to next and previous as they were
-   * added to the stack, rather than the way we see them in this
-   * walk. (It makes the next loop less confusing.)  
-   *
-   * Stop if we find an update frame pointing to a black hole 
-   * (see comment in threadLazyBlackHole()).
-   */
-  
-  next_frame = NULL;
-  // bottom - sizeof(StgStopFrame) is the STOP_FRAME 
-  while ((P_)frame < bottom - sizeofW(StgStopFrame)) {  
-    prev_frame = frame->link;
-    frame->link = next_frame;
-    next_frame = frame;
-    frame = prev_frame;
-#if DEBUG
-    IF_DEBUG(sanity,
-	     if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
-	       printObj((StgClosure *)prev_frame);
-	       barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n", 
-		    frame, prev_frame);
-	     })
-    switch (get_itbl(frame)->type) {
-    case UPDATE_FRAME:
-	upd_frames++;
-	if (frame->updatee->header.info == &stg_BLACKHOLE_info)
-	    bhs++;
-	break;
-    case STOP_FRAME:
-	stop_frames++;
-	break;
-    case CATCH_FRAME:
-	catch_frames++;
-	break;
-    case SEQ_FRAME:
-	seq_frames++;
-	break;
-    default:
-      barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
-	   frame, prev_frame);
-      printObj((StgClosure *)prev_frame);
-    }
-#endif
-    if (get_itbl(frame)->type == UPDATE_FRAME
-	&& frame->updatee->header.info == &stg_BLACKHOLE_info) {
-        break;
-    }
-  }
+    frame = tso->sp;
 
-  /* Now, we're at the bottom.  Frame points to the lowest update
-   * frame on the stack, and its link actually points to the frame
-   * above. We have to walk back up the stack, squeezing out empty
-   * update frames and turning the pointers back around on the way
-   * back up.
-   *
-   * The bottom-most frame (the STOP_FRAME) has not been altered, and
-   * we never want to eliminate it anyway.  Just walk one step up
-   * before starting to squeeze. When you get to the topmost frame,
-   * remember that there are still some words above it that might have
-   * to be moved.  
-   */
-  
-  prev_frame = frame;
-  frame = next_frame;
+    ASSERT(frame < bottom);
+    
+    prev_was_update_frame = rtsFalse;
+    current_gap_size = 0;
+    gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
 
-  prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
+    while (frame < bottom) {
+	
+	info = get_ret_itbl((StgClosure *)frame);
+	switch (info->i.type) {
 
-  /*
-   * Loop through all of the frames (everything except the very
-   * bottom).  Things are complicated by the fact that we have 
-   * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
-   * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
-   */
-  while (frame != NULL) {
-    StgPtr sp;
-    StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
-    rtsBool is_update_frame;
-    
-    next_frame = frame->link;
-    is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
+	case UPDATE_FRAME:
+	{ 
+	    StgUpdateFrame *upd = (StgUpdateFrame *)frame;
 
-    /* Check to see if 
-     *   1. both the previous and current frame are update frames
-     *   2. the current frame is empty
-     */
-    if (prev_was_update_frame && is_update_frame &&
-	(P_)prev_frame == frame_bottom + displacement) {
-      
-      // Now squeeze out the current frame 
-      StgClosure *updatee_keep   = prev_frame->updatee;
-      StgClosure *updatee_bypass = frame->updatee;
-      
-#if DEBUG
-      IF_DEBUG(gc, fprintf(stderr, "@@ squeezing frame at %p\n", frame));
-      squeezes++;
-#endif
+	    if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
 
-      /* Deal with blocking queues.  If both updatees have blocked
-       * threads, then we should merge the queues into the update
-       * frame that we're keeping.
-       *
-       * Alternatively, we could just wake them up: they'll just go
-       * straight to sleep on the proper blackhole!  This is less code
-       * and probably less bug prone, although it's probably much
-       * slower --SDM
-       */
-#if 0 // do it properly... 
-#  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
-#    error Unimplemented lazy BH warning.  (KSW 1999-01)
-#  endif
-      if (GET_INFO(updatee_bypass) == stg_BLACKHOLE_BQ_info
-	  || GET_INFO(updatee_bypass) == stg_CAF_BLACKHOLE_info
-	  ) {
-	// Sigh.  It has one.  Don't lose those threads! 
-	  if (GET_INFO(updatee_keep) == stg_BLACKHOLE_BQ_info) {
-	  // Urgh.  Two queues.  Merge them. 
-	  P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
-	  
-	  while (keep_tso->link != END_TSO_QUEUE) {
-	    keep_tso = keep_tso->link;
-	  }
-	  keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
+		// found a BLACKHOLE'd update frame; we've been here
+		// before, in a previous GC, so just break out.
 
-	} else {
-	  // For simplicity, just swap the BQ for the BH 
-	  P_ temp = updatee_keep;
-	  
-	  updatee_keep = updatee_bypass;
-	  updatee_bypass = temp;
-	  
-	  // Record the swap in the kept frame (below) 
-	  prev_frame->updatee = updatee_keep;
-	}
-      }
-#endif
+		// Mark the end of the gap, if we're in one.
+		if (current_gap_size != 0) {
+		    gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
+		}
+		
+		frame += sizeofW(StgUpdateFrame);
+		goto done_traversing;
+	    }
 
-      TICK_UPD_SQUEEZED();
-      /* wasn't there something about update squeezing and ticky to be
-       * sorted out?  oh yes: we aren't counting each enter properly
-       * in this case.  See the log somewhere.  KSW 1999-04-21
-       *
-       * Check two things: that the two update frames don't point to
-       * the same object, and that the updatee_bypass isn't already an
-       * indirection.  Both of these cases only happen when we're in a
-       * block hole-style loop (and there are multiple update frames
-       * on the stack pointing to the same closure), but they can both
-       * screw us up if we don't check.
-       */
-      if (updatee_bypass != updatee_keep && !closure_IND(updatee_bypass)) {
-	  // this wakes the threads up 
-	  UPD_IND_NOLOCK(updatee_bypass, updatee_keep);
-      }
-      
-      sp = (P_)frame - 1;	// sp = stuff to slide 
-      displacement += sizeofW(StgUpdateFrame);
-      
-    } else {
-      // No squeeze for this frame 
-      sp = frame_bottom - 1;	// Keep the current frame 
-      
-      /* Do lazy black-holing.
-       */
-      if (is_update_frame) {
-	StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
-	if (bh->header.info != &stg_BLACKHOLE_info &&
-	    bh->header.info != &stg_BLACKHOLE_BQ_info &&
-	    bh->header.info != &stg_CAF_BLACKHOLE_info) {
+	    if (prev_was_update_frame) {
+
+		TICK_UPD_SQUEEZED();
+		/* wasn't there something about update squeezing and ticky to be
+		 * sorted out?  oh yes: we aren't counting each enter properly
+		 * in this case.  See the log somewhere.  KSW 1999-04-21
+		 *
+		 * Check two things: that the two update frames don't point to
+		 * the same object, and that the updatee_bypass isn't already an
+		 * indirection.  Both of these cases only happen when we're in a
+		 * block hole-style loop (and there are multiple update frames
+		 * on the stack pointing to the same closure), but they can both
+		 * screw us up if we don't check.
+		 */
+		if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
+		    // this wakes the threads up 
+		    UPD_IND_NOLOCK(upd->updatee, updatee);
+		}
+
+		// now mark this update frame as a stack gap.  The gap
+		// marker resides in the bottom-most update frame of
+		// the series of adjacent frames, and covers all the
+		// frames in this series.
+		current_gap_size += sizeofW(StgUpdateFrame);
+		((struct stack_gap *)frame)->gap_size = current_gap_size;
+		((struct stack_gap *)frame)->next_gap = gap;
+
+		frame += sizeofW(StgUpdateFrame);
+		continue;
+	    } 
+
+	    // single update frame, or the topmost update frame in a series
+	    else {
+		StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
+
+		// Do lazy black-holing
+		if (bh->header.info != &stg_BLACKHOLE_info &&
+		    bh->header.info != &stg_BLACKHOLE_BQ_info &&
+		    bh->header.info != &stg_CAF_BLACKHOLE_info) {
 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
-          fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
+		    debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh);
 #endif
 #ifdef DEBUG
-	  /* zero out the slop so that the sanity checker can tell
-	   * where the next closure is.
-	   */
-	  { 
-	      StgInfoTable *info = get_itbl(bh);
-	      nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
-	      /* don't zero out slop for a THUNK_SELECTOR, because it's layout
-	       * info is used for a different purpose, and it's exactly the
-	       * same size as a BLACKHOLE in any case.
-	       */
-	      if (info->type != THUNK_SELECTOR) {
-		for (i = np; i < np + nw; i++) {
-		  ((StgClosure *)bh)->payload[i] = 0;
-		}
-	      }
-	  }
+		    /* zero out the slop so that the sanity checker can tell
+		     * where the next closure is.
+		     */
+		    { 
+			StgInfoTable *bh_info = get_itbl(bh);
+			nat np = bh_info->layout.payload.ptrs, 
+			    nw = bh_info->layout.payload.nptrs, i;
+			/* don't zero out slop for a THUNK_SELECTOR,
+			 * because its layout info is used for a
+			 * different purpose, and it's exactly the
+			 * same size as a BLACKHOLE in any case.
+			 */
+			if (bh_info->type != THUNK_SELECTOR) {
+			    for (i = 0; i < np + nw; i++) {
+				((StgClosure *)bh)->payload[i] = INVALID_OBJECT;
+			    }
+			}
+		    }
 #endif
-	  SET_INFO(bh,&stg_BLACKHOLE_info);
+#ifdef PROFILING
+		    // We pretend that bh is now dead.
+		    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
+#endif
+		    // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
+		    SET_INFO(bh,&stg_BLACKHOLE_info);
+
+		    // We pretend that bh has just been created.
+		    LDV_RECORD_CREATE(bh);
+		}
+
+		prev_was_update_frame = rtsTrue;
+		updatee = upd->updatee;
+		frame += sizeofW(StgUpdateFrame);
+		continue;
+	    }
 	}
-      }
+	    
+	default:
+	    prev_was_update_frame = rtsFalse;
 
-      // Fix the link in the current frame (should point to the frame below) 
-      frame->link = prev_frame;
-      prev_was_update_frame = is_update_frame;
-    }
-    
-    // Now slide all words from sp up to the next frame 
-    
-    if (displacement > 0) {
-      P_ next_frame_bottom;
+	    // we're not in a gap... check whether this is the end of a gap
+	    // (an update frame can't be the end of a gap).
+	    if (current_gap_size != 0) {
+		gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
+	    }
+	    current_gap_size = 0;
 
-      if (next_frame != NULL)
-	next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
-      else
-	next_frame_bottom = tso->sp - 1;
-      
-#if DEBUG
-      IF_DEBUG(gc,
-	       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
-		       displacement))
-#endif
-      
-      while (sp >= next_frame_bottom) {
-	sp[displacement] = *sp;
-	sp -= 1;
-      }
+	    frame += stack_frame_sizeW((StgClosure *)frame);
+	    continue;
+	}
     }
-    (P_)prev_frame = (P_)frame + displacement;
-    frame = next_frame;
-  }
 
-  tso->sp += displacement;
-  tso->su = prev_frame;
-#if DEBUG
-  IF_DEBUG(gc,
-	   fprintf(stderr, "@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames\n",
-		   squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
-#endif
-}
+done_traversing:
+	    
+    // Now we have a stack with gaps in it, and we have to walk down
+    // shoving the stack up to fill in the gaps.  A diagram might
+    // help:
+    //
+    //    +| ********* |
+    //     | ********* | <- sp
+    //     |           |
+    //     |           | <- gap_start
+    //     | ......... |                |
+    //     | stack_gap | <- gap         | chunk_size
+    //     | ......... |                | 
+    //     | ......... | <- gap_end     v
+    //     | ********* | 
+    //     | ********* | 
+    //     | ********* | 
+    //    -| ********* | 
+    //
+    // 'sp'  points the the current top-of-stack
+    // 'gap' points to the stack_gap structure inside the gap
+    // *****   indicates real stack data
+    // .....   indicates gap
+    // <empty> indicates unused
+    //
+    {
+	void *sp;
+	void *gap_start, *next_gap_start, *gap_end;
+	nat chunk_size;
+
+	next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
+	sp = next_gap_start;
+
+	while ((StgPtr)gap > tso->sp) {
+
+	    // we're working in *bytes* now...
+	    gap_start = next_gap_start;
+	    gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
+
+	    gap = gap->next_gap;
+	    next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
 
+	    chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
+	    (unsigned char*)sp -= chunk_size;
+	    memmove(sp, next_gap_start, chunk_size);
+	}
+
+	tso->sp = (StgPtr)sp;
+    }
+}    
 
 /* -----------------------------------------------------------------------------
  * Pausing a thread
@@ -3818,12 +4494,12 @@ printMutOnceList(generation *gen)
   p = gen->mut_once_list;
   next = p->mut_link;
 
-  fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
+  debugBelch("@@ Mut once list %p: ", gen->mut_once_list);
   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
-    fprintf(stderr, "%p (%s), ", 
+    debugBelch("%p (%s), ", 
 	    p, info_type((StgClosure *)p));
   }
-  fputc('\n', stderr);
+  debugBelch("\n");
 }
 
 void
@@ -3834,15 +4510,15 @@ printMutableList(generation *gen)
   p = gen->mut_list;
   next = p->mut_link;
 
-  fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
+  debugBelch("@@ Mutable list %p: ", gen->mut_list);
   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
-    fprintf(stderr, "%p (%s), ",
+    debugBelch("%p (%s), ",
 	    p, info_type((StgClosure *)p));
   }
-  fputc('\n', stderr);
+  debugBelch("\n");
 }
 
-static inline rtsBool
+STATIC_INLINE rtsBool
 maybeLarge(StgClosure *closure)
 {
   StgInfoTable *info = get_itbl(closure);