[project @ 1996-01-08 20:28:12 by partain]

Initial revision

27 files changed, 11531 insertions, 0 deletions

diff --git a/ghc/runtime/storage/Force_GC.lc b/ghc/runtime/storage/Force_GC.lc
new file mode 100644
index 0000000000..0e5120a2d6
--- /dev/null
+++ b/ghc/runtime/storage/Force_GC.lc
@@ -0,0 +1,50 @@
+\section[Force_GC.lc]{Code for Forcing Garbage Collections}
+
+\begin{code}
+#include "rtsdefs.h"
+\end{code}
+
+Only have GC forcing if @FORCE_GC@ defined
+
+- currently only works with appel GC
+- in normal appel GC, if the force_gc flag is set *major* GC occurs
+  at the next scheduled minor GC if at least GCInterval word allocations have happened
+  since the last major GC.
+  (It also occurs when the normal conditions for a major GC is met)
+- if the force2s and force_gc flags are set 
+  (forcing appel GC to work as a 2 space GC) GC occurs
+  at least at every GCInterval word allocations 
+  (it also occurs when the semi-space limit is reached).
+  Therefore it has no effect if the interval specified is >= semi-space.
+    
+
+\begin{code}
+#if defined(FORCE_GC)
+\end{code}
+
+\begin{code}
+I_ force_GC = 0;     /* Global Flag */
+I_ GCInterval = DEFAULT_GC_INTERVAL;    /* words alloced */
+I_ alloc_since_last_major_GC = 0;    /* words alloced since last major GC */
+
+
+#endif /* FORCE_GC */
+\end{code}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/ghc/runtime/storage/SM1s.lc b/ghc/runtime/storage/SM1s.lc
new file mode 100644
index 0000000000..51265e5959
--- /dev/null
+++ b/ghc/runtime/storage/SM1s.lc
@@ -0,0 +1,197 @@
+***************************************************************************
+
+                      COMPACTING GARBAGE COLLECTION
+
+Additional Global Data Requirements:
+  ++ All the root locations are in malloced space (and info tables in
+     static data space). This is to simplify the location list end test.
+
+***************************************************************************
+
+[Someone needs to document this too. KH]
+
+\begin{code}
+#if defined(GC1s)
+
+ToDo:  Soft heap limits
+
+#define  SCAN_REG_DUMP
+#include "SMinternal.h"
+#include "SMcompacting.h"
+#include "SMextn.h"
+
+REGDUMP(ScanRegDump);
+
+compactingData compactingInfo = {0, 0, 0, 0, 0};
+
+P_ heap_space = 0;		/* Address of first word of slab 
+				   of memory allocated for heap */
+
+P_ hp_start;	        /* Value of Hp when reduction was resumed */
+
+I_
+initHeap( sm )
+    smInfo *sm;    
+{
+    if (heap_space == 0) { /* allocates if it doesn't already exist */
+
+	/* Allocate the roots space */
+	sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+
+	/* Allocate the heap */
+	heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+
+	compactingInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+	compactingInfo.bits      = (BitWord *)(heap_space + SM_word_heap_size) - compactingInfo.bit_words;
+
+	compactingInfo.heap_words =  SM_word_heap_size - compactingInfo.bit_words;
+	compactingInfo.base = HEAP_FRAME_BASE(heap_space, compactingInfo.heap_words);
+	compactingInfo.lim  = HEAP_FRAME_LIMIT(heap_space, compactingInfo.heap_words);
+
+	stat_init("COMPACTING", "", "");
+    }
+
+    sm->hp = hp_start = compactingInfo.base - 1;
+
+    if (SM_alloc_size) {
+	sm->hplim = sm->hp + SM_alloc_size;
+	SM_alloc_min = 0; /* No min; alloc size specified */
+
+	if (sm->hplim > compactingInfo.lim) {
+	    fprintf(stderr, "Not enough heap for requested alloc size\n");
+	    return -1;
+	}
+    } else {
+	sm->hplim = compactingInfo.lim;
+    }
+
+    sm->CAFlist = NULL;
+
+#ifndef PAR
+    initExtensions( sm );
+#endif /* !PAR */
+
+    if (SM_trace) {
+	fprintf(stderr, "COMPACTING Heap: Base 0x%lx, Lim 0x%lx, Bits 0x%lx, bit words 0x%lx\n",
+		(W_) compactingInfo.base, (W_) compactingInfo.lim,
+		(W_) compactingInfo.bits, (W_) compactingInfo.bit_words);
+	fprintf(stderr, "COMPACTING Initial: base 0x%lx, lim 0x%lx\n                    hp 0x%lx, hplim 0x%lx, free %lu\n",
+		(W_) compactingInfo.base,
+		(W_) compactingInfo.lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+    }
+
+    return 0;
+}
+
+I_
+collectHeap(reqsize, sm, do_full_collection)
+    W_ reqsize;
+    smInfo *sm;
+    rtsBool do_full_collection; /* ignored */
+{
+    I_ free_space,	/* No of words of free space following GC */
+        alloc, 		/* Number of words allocated since last GC */
+	resident;	/* Number of words remaining after GC */
+
+    SAVE_REGS(&ScanRegDump); /* Save registers */
+
+    if (SM_trace)
+      {
+        fflush(stdout);     /* Flush stdout at start of GC */
+	fprintf(stderr, "COMPACTING Start: base 0x%lx, lim 0x%lx\n                 hp 0x%lx, hplim 0x%lx, req %lu\n",
+		(W_) compactingInfo.base, (W_) compactingInfo.lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
+      }
+
+    alloc = sm->hp - hp_start;
+
+    stat_startGC(alloc);
+
+    /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAN_REG_MAP */
+    RESTORE_REGS(&ScanRegDump);
+
+    markHeapRoots(sm, sm->CAFlist, 0,
+		  compactingInfo.base,
+		  compactingInfo.lim,
+		  compactingInfo.bits);
+
+    SAVE_REGS(&ScanRegDump);
+    /* end of bracket */
+
+#ifndef PAR
+    sweepUpDeadMallocPtrs(sm->MallocPtrList, 
+			  compactingInfo.base, 
+			  compactingInfo.bits );
+#endif
+
+    LinkCAFs(sm->CAFlist);
+
+    LinkRoots( sm->roots, sm->rootno );
+#ifdef CONCURRENT
+    LinkSparks();
+#endif
+#ifdef PAR
+    LinkLiveGAs(compactingInfo.base, compactingInfo.bits);
+#else
+    DEBUG_STRING("Linking Stable Pointer Table:");
+    LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
+    LinkAStack( MAIN_SpA, stackInfo.botA );
+    LinkBStack( MAIN_SuB, stackInfo.botB );
+#endif /* parallel */
+
+    /* Do Inplace Compaction */
+    /* Returns start of next closure, -1 gives last allocated word */
+
+    sm->hp = Inplace_Compaction(compactingInfo.base,
+				compactingInfo.lim,
+				0, 0,
+				compactingInfo.bits,
+				compactingInfo.bit_words
+#if ! defined(PAR)
+				, &(sm->MallocPtrList)
+#endif
+				) - 1;
+
+    resident = sm->hp - (compactingInfo.base - 1);
+    DO_MAX_RESIDENCY(resident); /* stats only */
+
+    if (SM_alloc_size) {
+	sm->hplim = sm->hp + SM_alloc_size;
+	if (sm->hplim > compactingInfo.lim) {
+	    free_space = 0;
+	} else {
+	    free_space = SM_alloc_size;
+	}
+    } else {
+	sm->hplim = compactingInfo.lim;
+	free_space = sm->hplim - sm->hp;
+    }
+
+    hp_start = sm->hp;
+
+    stat_endGC(alloc, compactingInfo.heap_words, resident, "");
+
+    if (SM_trace)
+	fprintf(stderr, "COMPACTING Done: base 0x%lx, lim 0x%lx\n                    hp 0x%lx, hplim 0x%lx, free %lu\n",
+		(W_) compactingInfo.base, (W_) compactingInfo.lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
+
+#ifdef DEBUG
+    /* To help flush out bugs, we trash the part of the heap from
+       which we're about to start allocating. */
+    TrashMem(sm->hp+1, sm->hplim);
+#endif /* DEBUG */
+
+    RESTORE_REGS(&ScanRegDump);     /* Restore Registers */
+
+    if ((SM_alloc_min > free_space) || (reqsize > free_space))
+	return GC_HARD_LIMIT_EXCEEDED;	/* Heap exhausted */
+    else 
+	return GC_SUCCESS;		/* Heap OK */
+}
+
+#endif /* GC1s */
+
+\end{code}
+
diff --git a/ghc/runtime/storage/SM2s.lc b/ghc/runtime/storage/SM2s.lc
new file mode 100644
index 0000000000..1a50a0e841
--- /dev/null
+++ b/ghc/runtime/storage/SM2s.lc
@@ -0,0 +1,291 @@
+***************************************************************************
+
+                           TWO SPACE COLLECTION
+
+***************************************************************************
+
+\begin{code}
+#if defined(GC2s)
+
+#define SCAV_REG_MAP
+#include "SMinternal.h"
+#include "SMcopying.h"
+#include "SMextn.h"
+
+REGDUMP(ScavRegDump);
+
+I_ semispace = 0;              /* 0 or 1 */
+semispaceData semispaceInfo[2]
+    = {{0,0}, {0,0}};
+
+P_ heap_space = 0;		/* Address of first word of slab 
+				   of memory allocated for heap */
+
+P_ hp_start;	        /* Value of Hp when reduction was resumed */
+
+
+I_ initHeap( sm )
+    smInfo *sm;    
+{
+    if (heap_space == 0) { /* allocates if it doesn't already exist */
+
+	I_ semispaceSize = SM_word_heap_size / 2;
+
+	/* Allocate the roots space */
+	sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+
+	/* Allocate the heap */
+	heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+    
+	/* Define the semi-spaces */
+	semispaceInfo[0].base = HEAP_FRAME_BASE(heap_space, semispaceSize);
+	semispaceInfo[1].base = HEAP_FRAME_BASE(heap_space + semispaceSize, semispaceSize);
+	semispaceInfo[0].lim = HEAP_FRAME_LIMIT(heap_space, semispaceSize);
+	semispaceInfo[1].lim = HEAP_FRAME_LIMIT(heap_space + semispaceSize, semispaceSize);
+
+	stat_init("TWOSPACE",
+		  " No of Roots  Caf   Caf    Astk   Bstk",
+		  "Astk Bstk Reg  No  bytes  bytes  bytes");
+    }
+
+    /* Initialise heap pointer and limit */
+    sm->hp = hp_start = semispaceInfo[semispace].base - 1;
+    sm->hardHpOverflowSize = 0;
+
+    if (SM_alloc_size) {
+	sm->hplim = sm->hp + SM_alloc_size;
+	SM_alloc_min = 0; /* No min; alloc size specified */
+
+	if (sm->hplim > semispaceInfo[semispace].lim) {
+	    fprintf(stderr, "Not enough heap for requested alloc size\n");
+	    return -1;
+	}
+    } else {
+	sm->hplim = semispaceInfo[semispace].lim;
+    }
+
+#if defined(FORCE_GC)
+    if (force_GC) {
+       if (sm->hplim > sm->hp + GCInterval) {
+          sm->hplim = sm->hp + GCInterval; 
+       }
+       else {
+          force_GC = 0; /* forcing GC has no effect, as semi-space is smaller than GCInterval */ 
+       }
+    }
+#endif /* FORCE_GC */
+
+#if defined(LIFE_PROFILE)
+    sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); /* space for HpLim incr */
+    if (do_life_prof) {
+	sm->hplim = sm->hp + LifeInterval;
+    }
+#endif /* LIFE_PROFILE */
+
+    sm->CAFlist = NULL;
+
+#ifndef PAR
+    initExtensions( sm );
+#endif /* !PAR */
+
+    if (SM_trace) {
+	fprintf(stderr, "TWO SPACE Heap: 0base, 0lim, 1base, 1lim\n                0x%lx, 0x%lx, 0x%lx, 0x%lx\n",
+		(W_) semispaceInfo[0].base, (W_) semispaceInfo[0].lim,
+		(W_) semispaceInfo[1].base, (W_) semispaceInfo[1].lim);
+	fprintf(stderr, "TWO SPACE Initial: space %ld, base 0x%lx, lim 0x%lx\n                         hp 0x%lx, hplim 0x%lx, free %lu\n",
+		semispace,
+		(W_) semispaceInfo[semispace].base,
+		(W_) semispaceInfo[semispace].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+    }
+
+    return 0;
+}
+
+I_
+collectHeap(reqsize, sm, do_full_collection)
+    W_ reqsize;
+    smInfo *sm;
+    rtsBool do_full_collection; /* ignored */
+{
+#if defined(LIFE_PROFILE)
+    I_ next_interval;  /* if doing profile */
+#endif
+
+    I_ free_space,	/* No of words of free space following GC */
+        alloc, 		/* Number of words allocated since last GC */
+	resident,	/* Number of words remaining after GC */
+        extra_caf_words,/* Extra words referenced from CAFs */
+        caf_roots,      /* Number of CAFs */
+        bstk_roots;     /* Number of update frames on B stack */
+
+    fflush(stdout);     /* Flush stdout at start of GC */
+    SAVE_REGS(&ScavRegDump); /* Save registers */
+
+#if defined(LIFE_PROFILE)
+    if (do_life_prof) {	life_profile_setup(); }
+#endif /* LIFE_PROFILE */
+
+#if defined(USE_COST_CENTRES)
+    if (interval_expired) { heap_profile_setup(); }
+#endif  /* USE_COST_CENTRES */
+  
+    if (SM_trace)
+	fprintf(stderr, "TWO SPACE Start: space %ld, base 0x%lx, lim 0x%lx\n                         hp 0x%lx, hplim 0x%lx, req %lu\n",
+		semispace, (W_) semispaceInfo[semispace].base,
+		(W_) semispaceInfo[semispace].lim,
+		(W_) sm->hp, (W_) sm->hplim, reqsize * sizeof(W_));
+
+    alloc = sm->hp - hp_start;
+    stat_startGC(alloc);
+
+    /* Set Up For Collecting:
+         - Flip Spaces
+	 - Set ToHp to point one below bottom of to-space (last allocated)
+	 - Set CAFs to Evac & Upd
+     */
+
+    semispace = NEXT_SEMI_SPACE(semispace);
+    ToHp = semispaceInfo[semispace].base - 1;
+    Scav = semispaceInfo[semispace].base;
+    
+    SetCAFInfoTables( sm->CAFlist );
+#ifdef PAR
+    EvacuateLocalGAs(rtsTrue);
+#else
+    evacSPTable( sm );
+#endif /* PAR */
+    EvacuateRoots( sm->roots, sm->rootno );
+#ifdef CONCURRENT
+    EvacuateSparks();
+#endif
+#ifndef PAR
+    EvacuateAStack( MAIN_SpA, stackInfo.botA );
+    EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
+#endif /* !PAR */
+
+    Scavenge();
+
+    EvacAndScavengeCAFs( sm->CAFlist, &extra_caf_words, &caf_roots );
+
+#ifdef PAR
+    RebuildGAtables(rtsTrue);
+#else
+    reportDeadMallocPtrs(sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+#endif /* PAR */
+
+    /* TIDY UP AND RETURN */
+
+    sm->hp = hp_start = ToHp;  /* Last allocated word */
+
+    resident = sm->hp - (semispaceInfo[semispace].base - 1);
+    DO_MAX_RESIDENCY(resident); /* stats only */
+
+    if (SM_alloc_size) {
+	sm->hplim = sm->hp + SM_alloc_size;
+	if (sm->hplim > semispaceInfo[semispace].lim) {
+	    free_space = 0;
+	} else {
+	    free_space = SM_alloc_size;
+	}
+    } else {
+	sm->hplim = semispaceInfo[semispace].lim;
+	free_space = sm->hplim - sm->hp;
+    }
+
+    if (SM_stats_verbose) {
+	char comment_str[BIG_STRING_LEN];
+#ifndef PAR
+	sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu",
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+		bstk_roots, sm->rootno,
+		caf_roots, extra_caf_words*sizeof(W_),
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
+		(SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
+#else
+	/* ToDo: come up with some interesting statistics for the parallel world */
+	sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu",
+		0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
+#endif
+
+#if defined(LIFE_PROFILE)
+	if (do_life_prof) {
+	    strcat(comment_str, " life");
+	}
+#endif
+#if defined(USE_COST_CENTRES)
+	if (interval_expired) {
+	    strcat(comment_str, " prof");
+	}
+#endif
+
+	stat_endGC(alloc, SM_word_heap_size, resident, comment_str);
+    } else {
+	stat_endGC(alloc, SM_word_heap_size, resident, "");
+    }
+
+#if defined(LIFE_PROFILE)
+      free_space = free_space / 2; /* space for HpLim incr */
+      if (do_life_prof) {
+	  next_interval = life_profile_done(alloc, reqsize);
+	  free_space -= next_interval;  /* ensure interval available */
+      }
+#endif /* LIFE_PROFILE */
+
+#if defined(USE_COST_CENTRES) || defined(GUM)
+      if (interval_expired) {
+#if defined(USE_COST_CENTRES)
+	  heap_profile_done();
+#endif
+	  report_cc_profiling(0 /*partial*/);
+      }
+#endif /* USE_COST_CENTRES */
+
+    if (SM_trace)
+	fprintf(stderr, "TWO SPACE Done: space %ld, base 0x%lx, lim 0x%lx\n                         hp 0x%lx, hplim 0x%lx, free %lu\n",
+		semispace, (W_) semispaceInfo[semispace].base,
+		(W_) semispaceInfo[semispace].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
+
+#ifdef DEBUG
+    /* To help flush out bugs, we trash the part of the heap from
+       which we're about to start allocating and all of the other semispace. */
+    TrashMem(sm->hp+1, sm->hplim);
+    TrashMem(semispaceInfo[NEXT_SEMI_SPACE(semispace)].base, 
+	     semispaceInfo[NEXT_SEMI_SPACE(semispace)].lim);
+#endif /* DEBUG */
+
+    RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+
+    if ( (SM_alloc_min > free_space) || (reqsize > free_space) ) {
+      return( GC_HARD_LIMIT_EXCEEDED );	/* Heap absolutely exhausted */
+    } else {
+
+#if defined(FORCE_GC)
+    if (force_GC) {
+       if (sm->hplim > sm->hp + GCInterval) {
+	  sm->hplim = sm->hp + GCInterval;
+       }
+    }
+#endif /* FORCE_GC */
++ 	  
+#if defined(LIFE_PROFILE)
+      /* space for HpLim incr */
+      sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2);
+      if (do_life_prof) {
+	  /* set hplim for next life profile */
+	  sm->hplim = sm->hp + next_interval;
+      }
+#endif /* LIFE_PROFILE */
+	  
+      if (reqsize + sm->hardHpOverflowSize > free_space) {
+	return( GC_SOFT_LIMIT_EXCEEDED );   /* Heap nearly exhausted */
+      } else {
+	return( GC_SUCCESS );		    /* Heap OK */
+      }
+    }
+}
+
+#endif /* GC2s */
+
+\end{code}
diff --git a/ghc/runtime/storage/SMalloc.lc b/ghc/runtime/storage/SMalloc.lc
new file mode 100644
index 0000000000..fa1bdab8e6
--- /dev/null
+++ b/ghc/runtime/storage/SMalloc.lc
@@ -0,0 +1,37 @@
+[
+ SMalloc seems a BAD choice of name.  I expected this to be the routines I
+ could use to allocate memory, not those used by the storage manager internally.
+
+ KH
+]
+
+Routines that deal with memory allocation:
+
+All dynamic allocation must be done before the stacks and heap are
+allocated. This allows us to use the lower level sbrk routines if
+required.
+
+\begin{code}
+#define NULL_REG_MAP
+#include "SMinternal.h"
+
+/* Return a ptr to n StgWords (note: WORDS not BYTES!) or die miserably */
+/* ToDo: Should allow use of valloc to allign on page boundary */
+
+char *
+#ifdef __STDC__
+xmalloc(size_t n)
+#else
+xmalloc(n)
+    size_t n;
+#endif
+{
+    char *space;
+
+    if ((space = (char *) malloc(n)) == NULL) {
+	MallocFailHook((W_) n); /*msg*/
+	EXIT(EXIT_FAILURE);
+    }
+    return space;
+}
+\end{code}
diff --git a/ghc/runtime/storage/SMap.lc b/ghc/runtime/storage/SMap.lc
new file mode 100644
index 0000000000..e82a986580
--- /dev/null
+++ b/ghc/runtime/storage/SMap.lc
@@ -0,0 +1,888 @@
+***************************************************************************
+
+                      APPEL'S GARBAGE COLLECTION
+
+Global heap requirements as for 1s and 2s collectors.
+    ++ All closures in the old generation that are updated must be
+       updated with indirections and placed on the linked list of
+       updated old generation closures.
+
+***************************************************************************
+
+\begin{code}
+#if defined(GCap)
+
+#define  SCAV_REG_MAP
+#include "SMinternal.h"
+#include "SMcopying.h"
+#include "SMcompacting.h"
+#include "SMextn.h"
+
+REGDUMP(ScavRegDump);
+
+appelData appelInfo = {0, 0, 0, 0, 0,
+		       0, 0, 0, 0, 0, 0, 0, 0, 0,
+		       0, {{0, 0}, {0, 0}}
+		      };
+
+P_ heap_space = 0;		/* Address of first word of slab 
+				   of memory allocated for heap */
+
+P_ hp_start;	        /* Value of Hp when reduction was resumed */
+
+#if defined(PROMOTION_DATA)     /* For dead promote & premature promote data */
+P_ thisbase;                /* Start of old gen before this minor collection */
+P_ prevbase;                /* Start of old gen before previous minor collection */
+I_ prev_prom = 0;              /* Promoted previous minor collection */
+I_ dead_prev_prom = 0;         /* Dead words promoted previous minor */
+#endif /* PROMOTION_DATA */
+
+#if defined(_GC_DEBUG)
+void
+debug_look_for (start, stop, villain)
+  P_ start, stop, villain;
+{
+    P_ i;
+    for (i = start; i <= stop; i++) {
+	if ( (P_) *i == villain ) {
+	    fprintf(stderr, "* %x : %x\n", i, villain);
+	}
+    }
+}
+#endif
+
+I_
+initHeap( sm )
+    smInfo *sm;    
+{
+    if (heap_space == 0) { /* allocates if it doesn't already exist */
+
+	/* Allocate the roots space */
+	sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+
+	/* Allocate the heap */
+	heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+
+	/* ToDo (ADR): trash entire heap contents */
+
+	if (SM_force_gc == USE_2s) {
+	    stat_init("TWOSPACE(APPEL)",
+		      " No of Roots  Caf   Caf    Astk   Bstk",
+		      "Astk Bstk Reg  No  bytes  bytes  bytes");
+	} else {
+	    stat_init("APPEL",
+		      " No of Roots  Caf  Mut-  Old  Collec  Resid",
+		      "Astk Bstk Reg  No  able  Gen   tion   %heap");
+	}
+    }
+    sm->hardHpOverflowSize = 0;
+
+    if (SM_force_gc == USE_2s) {
+	I_ semi_space_words = SM_word_heap_size / 2;
+	appelInfo.space[0].base = HEAP_FRAME_BASE(heap_space, semi_space_words);
+	appelInfo.space[1].base = HEAP_FRAME_BASE(heap_space + semi_space_words, semi_space_words);
+	appelInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, semi_space_words);
+	appelInfo.space[1].lim = HEAP_FRAME_LIMIT(heap_space + semi_space_words, semi_space_words);
+	appelInfo.semi_space = 0;
+	appelInfo.oldlim = heap_space - 1;  /* Never in old generation */
+
+	sm->hp = hp_start = appelInfo.space[appelInfo.semi_space].base - 1;
+
+	if (SM_alloc_size) {
+	    sm->hplim = sm->hp + SM_alloc_size;
+	    SM_alloc_min = 0; /* No min; alloc size specified */
+
+	    if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) {
+		fprintf(stderr, "Not enough heap for requested alloc size\n");
+		return -1;
+	    }
+	} else {
+	    sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
+	}
+
+#if defined(FORCE_GC)
+        if (force_GC) {
+	   if (sm->hplim > sm->hp + GCInterval) {
+              sm->hplim = sm->hp + GCInterval;
+           }
+           else {
+              /* no point in forcing GC, 
+                 as the semi-space is smaller than GCInterval */
+              force_GC = 0; 
+           }
+        }
+#endif /* FORCE_GC */
+
+#if defined(LIFE_PROFILE)
+        sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); /* space for HpLim incr */
+        if (do_life_prof) {
+	    sm->hplim = sm->hp + LifeInterval;
+        }
+#endif /* LIFE_PROFILE */
+
+	sm->OldLim = appelInfo.oldlim;
+	sm->CAFlist = NULL;
+
+#ifndef PAR
+	initExtensions( sm );
+#endif
+
+	if (SM_trace) {
+	    fprintf(stderr, "APPEL(2s) Heap: 0x%lx .. 0x%lx\n",
+		    (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size));
+	    fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n         hp 0x%lx, hplim 0x%lx, free %lu\n",
+		    appelInfo.semi_space,
+		    (W_) appelInfo.space[appelInfo.semi_space].base,
+		    (W_) appelInfo.space[appelInfo.semi_space].lim,
+		    (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+	}
+	return 0;
+    }
+
+
+/* So not forced 2s */
+
+    appelInfo.newlim  = heap_space + SM_word_heap_size - 1;
+    if (SM_alloc_size) {
+	appelInfo.newfixed = SM_alloc_size;
+	appelInfo.newmin   = SM_alloc_size;
+        appelInfo.newbase  = heap_space + SM_word_heap_size - appelInfo.newfixed;
+    } else {
+	appelInfo.newfixed = 0;
+	appelInfo.newmin   = SM_alloc_min;
+	appelInfo.newbase  = heap_space + (SM_word_heap_size / 2);
+    }
+
+    appelInfo.oldbase = heap_space;
+    appelInfo.oldlim  = heap_space - 1;
+    appelInfo.oldlast = heap_space - 1;
+    appelInfo.oldmax  = heap_space - 1 + SM_word_heap_size - 2*appelInfo.newmin;
+
+    if (appelInfo.oldbase > appelInfo.oldmax) {
+	fprintf(stderr, "Not enough heap for requested/minimum allocation area\n");
+	return -1;
+    }
+
+    appelInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+    appelInfo.bits      = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words;
+    if (appelInfo.bit_words > appelInfo.newmin)
+        appelInfo.oldmax = heap_space - 1 + SM_word_heap_size - appelInfo.bit_words - appelInfo.newmin;
+
+    if (SM_major_gen_size) {
+	appelInfo.oldthresh = heap_space -1 + SM_major_gen_size;
+	if (appelInfo.oldthresh > appelInfo.oldmax) {
+	    fprintf(stderr, "Not enough heap for requested major resid size\n");
+	    return -1;
+	}
+    } else {
+	appelInfo.oldthresh = heap_space + SM_word_heap_size * 2 / 3; /* Initial threshold -- 2/3rds */
+	if (appelInfo.oldthresh > appelInfo.oldmax)
+	    appelInfo.oldthresh = appelInfo.oldmax;
+    }
+
+    sm->hp = hp_start = appelInfo.newbase - 1;
+    sm->hplim = appelInfo.newlim;
+
+#if defined(FORCE_GC)
+        if (force_GC && (sm->hplim > sm->hp + GCInterval)) {
+              sm->hplim = sm->hp + GCInterval;
+           }
+#endif /* FORCE_GC */
+
+    sm->OldLim = appelInfo.oldlim;
+
+    sm->CAFlist = NULL;
+    appelInfo.OldCAFlist = NULL;
+    appelInfo.OldCAFno = 0;
+
+#ifndef PAR
+    initExtensions( sm );
+#endif
+
+    appelInfo.PromMutables = 0;
+
+#if defined(PROMOTION_DATA)   /* For dead promote & premature promote data */
+    prevbase = appelInfo.oldlim + 1;
+    thisbase = appelInfo.oldlim + 1;
+#endif /* PROMOTION_DATA */
+
+    if (SM_trace) {
+	fprintf(stderr, "APPEL Heap: 0x%lx .. 0x%lx\n",
+		(W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size));
+	fprintf(stderr, "Initial: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n         hp 0x%lx, hplim 0x%lx\n",
+		(W_) appelInfo.newbase, (W_) appelInfo.newlim,
+		(W_) appelInfo.oldbase, (W_) appelInfo.oldlim,
+		(W_) appelInfo.oldthresh, (W_) appelInfo.oldmax,
+		(W_) sm->hp, (W_) sm->hplim);
+    }
+
+    return 0;
+}
+
+static I_
+collect2s(reqsize, sm)
+    W_ reqsize;
+    smInfo *sm;
+{
+#if defined(LIFE_PROFILE)
+    I_ next_interval;  /* if doing profile */
+#endif
+    I_ free_space,	/* No of words of free space following GC */
+        alloc, 		/* Number of words allocated since last GC */
+	resident,	/* Number of words remaining after GC */
+        extra_caf_words,/* Extra words referenced from CAFs */
+        caf_roots,      /* Number of CAFs */
+        bstk_roots;     /* Number of update frames in B stack */
+
+    SAVE_REGS(&ScavRegDump);        /* Save registers */
+
+#if defined(LIFE_PROFILE)
+    if (do_life_prof) {	life_profile_setup(); }
+#endif /* LIFE_PROFILE */
+
+#if defined(USE_COST_CENTRES)
+    if (interval_expired) { heap_profile_setup(); }
+#endif  /* USE_COST_CENTRES */
+  
+    if (SM_trace)
+	fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, req %lu\n",
+		appelInfo.semi_space,
+		(W_) appelInfo.space[appelInfo.semi_space].base,
+		(W_) appelInfo.space[appelInfo.semi_space].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
+
+    alloc = sm->hp - hp_start;
+    stat_startGC(alloc);
+
+    appelInfo.semi_space = NEXT_SEMI_SPACE(appelInfo.semi_space);
+    ToHp = appelInfo.space[appelInfo.semi_space].base - 1;
+    Scav = appelInfo.space[appelInfo.semi_space].base;
+    OldGen = sm->OldLim; /* always evac ! */
+    
+    SetCAFInfoTables( sm->CAFlist );
+#ifdef PAR
+    EvacuateLocalGAs(rtsTrue);
+#else
+    evacSPTable( sm );
+#endif /* PAR */
+    EvacuateRoots( sm->roots, sm->rootno );
+#ifdef CONCURRENT
+    EvacuateSparks();
+#endif
+#ifndef PAR
+    EvacuateAStack( MAIN_SpA, stackInfo.botA );
+    EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
+#endif /* !PAR */
+
+    Scavenge();
+
+    EvacAndScavengeCAFs( sm->CAFlist, &extra_caf_words, &caf_roots );
+
+#ifdef PAR
+    RebuildGAtables(rtsTrue);
+#else
+    reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+#endif /* PAR */
+
+    /* TIDY UP AND RETURN */
+
+    sm->hp = hp_start = ToHp;  /* Last allocated word */
+ 
+    resident = sm->hp - (appelInfo.space[appelInfo.semi_space].base - 1);
+    DO_MAX_RESIDENCY(resident); /* stats only */
+
+    if (SM_alloc_size) {
+	sm->hplim = sm->hp + SM_alloc_size;
+	if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) {
+	    free_space = 0;
+	} else {
+	    free_space = SM_alloc_size;
+	}
+    } else {
+	sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
+	free_space = sm->hplim - sm->hp;
+    }
+
+#if defined(FORCE_GC)
+    if (force_GC && (sm->hplim > sm->hp + GCInterval)) {
+              sm->hplim = sm->hp + GCInterval;
+           }
+#endif /* FORCE_GC */
+
+    if (SM_stats_verbose) {
+	char comment_str[BIG_STRING_LEN];
+#ifndef PAR
+	sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+		bstk_roots, sm->rootno,
+		caf_roots, extra_caf_words*sizeof(W_),
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
+		(SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
+#else
+	/* ToDo: come up with some interesting statistics for the parallel world */
+	sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
+		0, 0L, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0L, 0L);
+
+#endif
+
+#if defined(LIFE_PROFILE)
+	if (do_life_prof) {
+	    strcat(comment_str, " life");
+	}
+#endif
+#if defined(USE_COST_CENTRES)
+	if (interval_expired) {
+	    strcat(comment_str, " prof");
+	}
+#endif
+
+	stat_endGC(alloc, SM_word_heap_size, resident, comment_str);
+    } else {
+	stat_endGC(alloc, SM_word_heap_size, resident, "");
+    }
+
+#if defined(LIFE_PROFILE)
+      free_space = free_space / 2; /* space for HpLim incr */
+      if (do_life_prof) {
+	  next_interval = life_profile_done(alloc, reqsize);
+	  free_space -= next_interval;  /* ensure interval available */
+      }
+#endif /* LIFE_PROFILE */
+
+#if defined(USE_COST_CENTRES) || defined(GUM)
+      if (interval_expired) {
+# if defined(USE_COST_CENTRES)
+	  heap_profile_done();
+# endif
+	  report_cc_profiling(0 /*partial*/);
+      }
+#endif /* USE_COST_CENTRES */
+
+    if (SM_trace)
+	fprintf(stderr, "Done:  space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, free %lu\n",
+		appelInfo.semi_space,
+		(W_) appelInfo.space[appelInfo.semi_space].base,
+		(W_) appelInfo.space[appelInfo.semi_space].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
+
+#ifdef DEBUG
+	/* To help flush out bugs, we trash the part of the heap from
+	   which we're about to start allocating, and all of the space
+           we just came from. */
+    {
+      I_ old_space = NEXT_SEMI_SPACE(appelInfo.semi_space);
+      TrashMem(appelInfo.space[old_space].base, appelInfo.space[old_space].lim);
+      TrashMem(sm->hp+1, sm->hplim);
+    }
+#endif /* DEBUG */
+
+    RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+
+    if ( (SM_alloc_min > free_space) || (reqsize > free_space) ) {
+      return( GC_HARD_LIMIT_EXCEEDED );	/* Heap absolutely exhausted */
+    } else {
+
+#if defined(LIFE_PROFILE)
+	/* ToDo: this may not be right now (WDP 94/11) */
+
+	/* space for HpLim incr */
+	sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2);
+	if (do_life_prof) {
+	    /* set hplim for next life profile */
+	    sm->hplim = sm->hp + next_interval;
+	}
+#endif /* LIFE_PROFILE */
+
+	if (reqsize + sm->hardHpOverflowSize > free_space) {
+	  return( GC_SOFT_LIMIT_EXCEEDED );	/* Heap nearly exhausted */
+	} else {
+	  return( GC_SUCCESS );          /* Heap OK */
+	}
+    }
+}
+
+
+I_
+collectHeap(reqsize, sm, do_full_collection)
+    W_ reqsize;
+    smInfo *sm;
+    rtsBool do_full_collection; /* do a major collection regardless? */
+{
+    I_ bstk_roots, caf_roots, mutable, old_words;
+    P_ oldptr, old_start, mutptr, prevmut;
+    P_ CAFptr, prevCAF;
+    P_ next;
+
+    I_ alloc, 		/* Number of words allocated since last GC */
+	resident;	/* Number of words remaining after GC */
+
+#if defined(PROMOTION_DATA)   /* For dead promote & premature promote data */
+    I_ promote,        /* Promoted this minor collection */
+        dead_prom,      /* Dead words promoted this minor */
+        dead_prev;      /* Promoted words that died since previos minor collection */
+    I_  root;
+    P_ base[2];
+#endif /* PROMOTION_DATA */
+
+    fflush(stdout);     /* Flush stdout at start of GC */
+
+    if (SM_force_gc == USE_2s) {
+	return collect2s(reqsize, sm);
+    }
+
+    SAVE_REGS(&ScavRegDump); /* Save registers */
+
+    if (SM_trace)
+	fprintf(stderr, "Start: newbase 0x%lx, newlim 0x%lx\n        hp 0x%lx, hplim 0x%lx, req %lu\n",
+		(W_) appelInfo.newbase, (W_) appelInfo.newlim, (W_) sm->hp, (W_) sm->hplim, reqsize * sizeof(W_));
+
+    alloc = sm->hp - hp_start;
+    stat_startGC(alloc);
+
+#ifdef FORCE_GC
+    alloc_since_last_major_GC += sm->hplim - hp_start;
+    /* this is indeed supposed to be less precise than alloc above */
+#endif /* FORCE_GC */
+
+    /* COPYING COLLECTION */
+
+    /* Set ToHp to end of old gen */
+    ToHp = appelInfo.oldlim;
+
+    /* Set OldGen register so we only evacuate new gen closures */
+    OldGen = appelInfo.oldlim;
+
+    /* FIRST: Evacuate and Scavenge CAFs and roots in the old generation */
+    old_start = ToHp;
+
+    SetCAFInfoTables( sm->CAFlist );
+
+    DEBUG_STRING("Evacuate CAFs:");
+    caf_roots = 0;
+    CAFptr = sm->CAFlist;
+    prevCAF = ((P_)(&sm->CAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */
+    while (CAFptr) {
+      EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
+      caf_roots++;
+      prevCAF = CAFptr;
+      CAFptr = (P_) IND_CLOSURE_LINK(CAFptr);
+    }
+    IND_CLOSURE_LINK(prevCAF) = (W_) appelInfo.OldCAFlist;
+    appelInfo.OldCAFlist = sm->CAFlist;
+    appelInfo.OldCAFno += caf_roots;
+    sm->CAFlist = NULL;
+
+    DEBUG_STRING("Evacuate Mutable Roots:");
+    mutable = 0;
+    mutptr = sm->OldMutables;
+    /* Clever, but completely illegal: */
+    prevmut = ((P_)&sm->OldMutables) - FIXED_HS;
+				/* See MUT_LINK */
+    while ( mutptr ) {
+
+	/* Scavenge the OldMutable */
+	P_ info = (P_) INFO_PTR(mutptr);
+	StgScavPtr scav_code = SCAV_CODE(info);
+	Scav = mutptr;
+	(scav_code)();
+
+	/* Remove from OldMutables if no longer mutable */
+	if (!IS_MUTABLE(info)) {
+    	    P_ tmp = mutptr;
+	    MUT_LINK(prevmut) = MUT_LINK(mutptr);
+	    mutptr = (P_) MUT_LINK(mutptr);
+	    MUT_LINK(tmp) = MUT_NOT_LINKED;
+	} else {
+	    prevmut = mutptr;
+	    mutptr = (P_) MUT_LINK(mutptr);
+	}
+	mutable++;
+    }
+
+#ifdef PAR
+    EvacuateLocalGAs(rtsFalse);
+#else
+    evacSPTable( sm );
+#endif /* PAR */
+
+    DEBUG_STRING("Scavenge evacuated old generation roots:");
+
+    Scav = appelInfo.oldlim + 1; /* Point to (info field of) first closure */
+
+    Scavenge();
+
+    old_words = ToHp - old_start;
+
+    /* PROMOTE closures rooted in the old generation and reset list of old gen roots */
+
+    appelInfo.oldlim = ToHp;
+
+    /* SECOND: Evacuate and scavenge remaining roots
+               These may already have been evacuated -- just get new address
+    */
+
+    EvacuateRoots( sm->roots, sm->rootno );
+
+#ifdef CONCURRENT
+    EvacuateSparks();
+#endif
+#ifndef PAR
+    EvacuateAStack( MAIN_SpA, stackInfo.botA );
+    EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
+    /* ToDo: Optimisation which squeezes out garbage update frames */
+#endif	/* PAR */
+
+    Scav = appelInfo.oldlim + 1; /* Point to (info field of) first closure */
+
+    Scavenge();
+
+    appelInfo.oldlim = ToHp;
+
+    /* record newly promoted mutuple roots */
+    MUT_LINK(prevmut) = (W_) appelInfo.PromMutables;
+    appelInfo.PromMutables = 0;
+
+    /* set new generation base, if not fixed */
+    if (! appelInfo.newfixed) {
+	appelInfo.newbase = appelInfo.oldlim + 1 + (((appelInfo.newlim - appelInfo.oldlim) + 1) / 2);
+    }
+
+#ifdef PAR
+    RebuildGAtables(rtsFalse);
+#else
+    reportDeadMallocPtrs(sm->MallocPtrList, 
+			 sm->OldMallocPtrList, 
+			 &(sm->OldMallocPtrList));
+    sm->MallocPtrList = NULL;   /* all (new) MallocPtrs have been promoted */
+#endif /* PAR */
+
+    resident = appelInfo.oldlim - sm->OldLim;
+    /* DONT_DO_MAX_RESIDENCY -- it is just a minor collection */
+
+    if (SM_stats_verbose) {
+	char minor_str[BIG_STRING_LEN];
+#ifndef PAR
+	sprintf(minor_str, "%4u %4ld %3ld %3ld  %4ld        Minor",
+	      (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+	      bstk_roots, sm->rootno, caf_roots, mutable); /* oldnew_roots, old_words */
+#else
+	/* ToDo: come up with some interesting statistics for the parallel world */
+	sprintf(minor_str, "%4u %4ld %3ld %3ld  %4ld        Minor",
+		0, 0L, sm->rootno, caf_roots, mutable);
+#endif
+	stat_endGC(alloc, alloc, resident, minor_str);
+    } else {
+	stat_endGC(alloc, alloc, resident, "");
+    }
+
+    /* Note: if do_full_collection we want to force a full collection. [ADR] */
+
+#ifdef FORCE_GC
+    if (force_GC && (alloc_since_last_major_GC >= GCInterval)) { 
+       do_full_collection = 1; 
+    }
+#endif /* FORCE_GC */
+
+#if defined(PROMOTION_DATA)   /* For dead promote & premature promote data major required */
+
+    if (! SM_stats_verbose &&
+	(appelInfo.oldlim < appelInfo.oldthresh) &&
+	(reqsize + sm->hardHpOverflowSize <= appelInfo.newlim - appelInfo.newbase) &&
+	(! do_full_collection) ) {
+
+#else  /* ! PROMOTION_DATA */
+
+    if ((appelInfo.oldlim < appelInfo.oldthresh) &&
+	(reqsize + sm->hardHpOverflowSize <= appelInfo.newlim - appelInfo.newbase) &&
+	(! do_full_collection) ) {
+
+#endif /* ! PROMOTION_DATA */
+
+	sm->hp = hp_start = appelInfo.newbase - 1;
+	sm->hplim = appelInfo.newlim;
+
+#if defined(FORCE_GC)
+        if (force_GC && 
+            (alloc_since_last_major_GC + (sm->hplim - hp_start) > GCInterval))
+        {
+              sm->hplim = sm->hp + (GCInterval - alloc_since_last_major_GC);
+        }
+#endif /* FORCE_GC */
+
+	sm->OldLim = appelInfo.oldlim;
+
+	if (SM_trace) {
+	    fprintf(stderr, "Minor: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n        hp 0x%lx, hplim 0x%lx, free %lu\n",
+		    (W_) appelInfo.newbase,   (W_) appelInfo.newlim,
+		    (W_) appelInfo.oldbase,   (W_) appelInfo.oldlim,
+		    (W_) appelInfo.oldthresh, (W_) appelInfo.oldmax,
+		    (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+	}
+
+#ifdef DEBUG
+	/* To help flush out bugs, we trash the part of the heap from
+	   which we're about to start allocating. */
+	TrashMem(sm->hp+1, sm->hplim);
+#endif /* DEBUG */
+
+        RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+
+	return GC_SUCCESS;           /* Heap OK -- Enough space to continue */
+    }
+
+    DEBUG_STRING("Major Collection Required");
+
+#ifdef FORCE_GC
+    alloc_since_last_major_GC = 0;
+#endif /* FORCE_GC */
+
+    stat_startGC(0);
+
+    alloc = (appelInfo.oldlim - appelInfo.oldbase) + 1;
+
+#if defined(PROMOTION_DATA)   /* For dead promote & premature promote data */
+    if (SM_stats_verbose) {
+	promote = appelInfo.oldlim - thisbase + 1;
+    }
+#endif /* PROMOTION_DATA */
+
+    appelInfo.bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+    appelInfo.bits      = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words;
+			  /* For some reason, this doesn't seem to use the last
+			     allocatable word at appelInfo.newlim */
+
+    if (appelInfo.bits <= appelInfo.oldlim) {
+	fprintf(stderr, "APPEL Major: Not enough space for bit vector\n");
+	return GC_HARD_LIMIT_EXCEEDED;
+    }
+
+    /* Zero bit vector for marking phase of major collection */
+    { BitWord *ptr = appelInfo.bits,
+	      *end = appelInfo.bits + appelInfo.bit_words;
+      while (ptr < end) { *(ptr++) = 0; };
+    }
+    
+#ifdef HAVE_VADVISE
+    vadvise(VA_ANOM);
+#endif
+
+    /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
+    RESTORE_REGS(&ScavRegDump);
+
+    markHeapRoots(sm, 
+		  appelInfo.OldCAFlist,
+		  NULL,
+		  appelInfo.oldbase,
+		  appelInfo.oldlim,
+		  appelInfo.bits);
+
+    SAVE_REGS(&ScavRegDump);
+    /* end of bracket */
+
+#ifndef PAR
+    sweepUpDeadMallocPtrs(sm->OldMallocPtrList, 
+			  appelInfo.oldbase, 
+			  appelInfo.bits 
+			  );
+#endif /* !PAR */
+
+    /* Reset OldMutables -- this will be reconstructed during scan */
+    sm->OldMutables = 0;
+
+    LinkCAFs(appelInfo.OldCAFlist);
+
+#if defined(PROMOTION_DATA)   /* For dead promote & premature promote data */
+    /* What does this have to do with CAFs? -- JSM */
+    if (SM_stats_verbose) {
+	base[0] = thisbase;
+	base[1] = prevbase;
+
+	if (SM_trace) {
+	    fprintf(stderr, "Promote Bases: lim 0x%lx this 0x%lx prev 0x%lx Actual: ",
+		    appelInfo.oldlim + 1, thisbase, prevbase);
+	}
+	
+	/* search for first live closure for thisbase & prevbase */
+	for (root = 0; root < 2; root++) {
+	    P_ baseptr, search, scan_w_start;
+	    I_ prev_words, bit_words, bit_rem;
+	    BitWord *bit_array_ptr, *bit_array_end;
+	    
+	    baseptr = base[root];
+	    prev_words = (baseptr - appelInfo.oldbase);
+	    bit_words  = prev_words / BITS_IN(BitWord);
+	    bit_rem    = prev_words & (BITS_IN(BitWord) - 1);
+	    
+	    bit_array_ptr = appelInfo.bits + bit_words;
+	    bit_array_end = appelInfo.bits + appelInfo.bit_words;
+	    scan_w_start  = baseptr - bit_rem;
+	    
+	    baseptr = 0;
+	    while (bit_array_ptr < bit_array_end && !baseptr) {
+		BitWord w = *(bit_array_ptr++);
+		search = scan_w_start;
+		if (bit_rem) {
+		    search += bit_rem;
+		    w >>= bit_rem;
+		    bit_rem = 0;		
+		}
+		while (w && !baseptr) {
+		    if (w & 0x1) {     /* bit set -- found first closure */
+			baseptr = search;
+		    } else {
+			search++;      /* look at next bit */
+			w >>= 1;
+		    }
+		}
+		scan_w_start += BITS_IN(BitWord);
+	    }
+	    if (SM_trace) {
+		fprintf(stderr, "0x%lx%s", baseptr, root == 2 ? "\n" : " ");
+	    }
+	    
+	    base[root] = baseptr;
+	    if (baseptr) {
+		LINK_LOCATION_TO_CLOSURE(base + root);
+	    }
+	}
+    }
+#endif /* PROMOTION_DATA */
+
+    LinkRoots( sm->roots, sm->rootno );
+#ifdef CONCURRENT
+    LinkSparks();
+#endif
+#ifdef PAR
+    LinkLiveGAs(appelInfo.oldbase, appelInfo.bits);
+#else
+    DEBUG_STRING("Linking Stable Pointer Table:");
+    LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
+    LinkAStack( MAIN_SpA, stackInfo.botA );
+    LinkBStack( MAIN_SuB, stackInfo.botB );
+#endif
+
+    /* Do Inplace Compaction */
+    /* Returns start of next closure, -1 gives last allocated word */
+
+    appelInfo.oldlim = Inplace_Compaction(appelInfo.oldbase,
+					  appelInfo.oldlim,
+					  0, 0,
+					  appelInfo.bits,
+					  appelInfo.bit_words
+#ifndef PAR
+					  ,&(sm->OldMallocPtrList)
+#endif
+					  ) - 1;
+
+    appelInfo.oldlast = appelInfo.oldlim; 
+    resident = (appelInfo.oldlim - appelInfo.oldbase) + 1;
+    DO_MAX_RESIDENCY(resident); /* stats only */
+
+    /* set new generation base, if not fixed */
+    if (! appelInfo.newfixed) {
+	appelInfo.newbase = appelInfo.oldlim + 1 + (((appelInfo.newlim - appelInfo.oldlim) + 1) / 2);
+    }
+
+    /* set major threshold, if not fixed */
+    /* next major collection when old gen occupies 2/3rds of the free space or exceeds oldmax */
+    if (! SM_major_gen_size) {
+	appelInfo.oldthresh = appelInfo.oldlim + (appelInfo.newlim - appelInfo.oldlim) * 2 / 3;
+	if (appelInfo.oldthresh > appelInfo.oldmax)
+	    appelInfo.oldthresh = appelInfo.oldmax;
+    }
+
+    sm->hp = hp_start = appelInfo.newbase - 1;
+    sm->hplim = appelInfo.newlim;
+    
+#if defined(FORCE_GC)
+        if (force_GC && (sm->hplim > sm->hp + GCInterval)) {
+              sm->hplim = sm->hp + GCInterval;
+        }
+#endif /* FORCE_GC */
+
+    sm->OldLim = appelInfo.oldlim;
+
+#if defined(PROMOTION_DATA)   /* For dead promote & premature promote data */
+    if (SM_stats_verbose) {
+	/* restore moved thisbase & prevbase */
+	thisbase = base[0] ? base[0] : appelInfo.oldlim + 1;
+	prevbase = base[1] ? base[1] : appelInfo.oldlim + 1;
+
+	/* here are the numbers we want */
+	dead_prom = promote - (appelInfo.oldlim + 1 - thisbase);
+	dead_prev = prev_prom - (thisbase - prevbase) - dead_prev_prom;
+
+	if (SM_trace) {
+	    fprintf(stderr, "Collect Bases: lim 0x%lx this 0x%lx prev 0x%lx\n",
+		    appelInfo.oldlim + 1, thisbase, prevbase);
+	    fprintf(stderr, "Promoted: %ld Dead: this %ld prev %ld + %ld\n",
+		    promote, dead_prom, dead_prev_prom, dead_prev);
+	}
+
+	/* save values for next collection */
+	prev_prom = promote;
+	dead_prev_prom = dead_prom;
+	prevbase = thisbase;
+	thisbase = appelInfo.oldlim + 1;
+    }
+#endif /* PROMOTION_DATA */
+
+#ifdef HAVE_VADVISE
+    vadvise(VA_NORM);
+#endif
+
+    if (SM_stats_verbose) {
+	char major_str[BIG_STRING_LEN];
+#ifndef PAR
+	sprintf(major_str, "%4u %4ld %3ld %3ld  %4d %4d  *Major* %4.1f%%",
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+		bstk_roots, sm->rootno, appelInfo.OldCAFno,
+		0, 0, resident / (StgFloat) SM_word_heap_size * 100);
+#else
+	/* ToDo: come up with some interesting statistics for the parallel world */
+	sprintf(major_str, "%4u %4ld %3ld %3ld  %4d %4d  *Major* %4.1f%%",
+		0, 0L, sm->rootno, appelInfo.OldCAFno, 0, 0,
+		resident / (StgFloat) SM_word_heap_size * 100);
+#endif
+
+#if defined(PROMOTION_DATA)   /* For dead promote & premature promote data */
+	{ char *promote_str[BIG_STRING_LEN];
+          sprintf(promote_str, " %6ld %6ld", dead_prom*sizeof(W_), dead_prev*sizeof(W_));
+	  strcat(major_str, promote_str);
+        }
+#endif /* PROMOTION_DATA */
+
+	stat_endGC(0, alloc, resident, major_str);
+    } else { 
+	stat_endGC(0, alloc, resident, "");
+    }
+
+    if (SM_trace) {
+	fprintf(stderr, "Major: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n        hp 0x%lx, hplim 0x%lx, free %lu\n",
+		(W_) appelInfo.newbase,   (W_) appelInfo.newlim,
+		(W_) appelInfo.oldbase,   (W_) appelInfo.oldlim,
+		(W_) appelInfo.oldthresh, (W_) appelInfo.oldmax,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+    }
+
+#ifdef DEBUG
+    /* To help flush out bugs, we trash the part of the heap from
+       which we're about to start allocating. */
+    TrashMem(sm->hp+1, sm->hplim);
+#endif /* DEBUG */
+
+    RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+
+    if ((appelInfo.oldlim > appelInfo.oldmax)
+	|| (reqsize > sm->hplim - sm->hp) ) {
+      return( GC_HARD_LIMIT_EXCEEDED );	/* Heap absolutely exhausted */
+    } else if (reqsize + sm->hardHpOverflowSize > sm->hplim - sm->hp) {
+      return( GC_SOFT_LIMIT_EXCEEDED );	/* Heap nearly exhausted */
+    } else {
+      return( GC_SUCCESS );          /* Heap OK */
+    }
+}
+
+#endif /* GCap */
+
+\end{code}
diff --git a/ghc/runtime/storage/SMcheck.lc b/ghc/runtime/storage/SMcheck.lc
new file mode 100644
index 0000000000..1318021f97
--- /dev/null
+++ b/ghc/runtime/storage/SMcheck.lc
@@ -0,0 +1,127 @@
+\section[storage-manager-check]{Checking Consistency of Storage Manager}
+
+This code performs consistency/sanity checks on the stacks and heap.
+It can be called each time round the mini-interpreter loop.  Not
+required if we're tail-jumping (no mini-interpreter).
+
+\begin{code}
+
+#if ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) )
+
+/* Insist on the declaration of STG-machine registers */
+#define MAIN_REG_MAP
+
+#include "SMinternal.h"
+
+#define isHeapPtr(p) \
+    ((p) >= heap_space && (p) < heap_space + SM_word_heap_size)
+
+#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
+#define validInfoPtr(i) \
+    ((i) < (StgPtr) (get_end_result) /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */)
+        /* No Internal info tables allowed (type -1) */
+
+#else /* non-NeXT */
+#define validInfoPtr(i) \
+    ((i) < (P_) &end /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */)
+        /* No Internal info tables allowed (type -1) */
+
+#endif /* non-NeXT */
+
+#define suspectPtr(p) ((p) < (P_)256)
+
+#if defined(GC2s)
+#define validHeapPtr(p) \
+    ((p) >= semispaceInfo[semispace].base && (p) <= semispaceInfo[semispace].lim)
+#else
+#if defined(GC1s)
+#define validHeapPtr(p) \
+    ((p) >= compactingInfo.base && (p) <= compactingInfo.lim)
+#else
+#if defined(GCdu)
+#define validHeapPtr(p) \
+    ((p) >= dualmodeInfo.modeinfo[dualmodeInfo.mode].base && \
+     (p) <= dualmodeInfo.modeinfo[dualmodeInfo.mode].lim)
+
+#else
+#if defined(GCap)
+/* Two cases needed, depending on whether the 2-space GC is forced
+   SLPJ 17 June 93 */
+#define validHeapPtr(p)							\
+    (SM_force_gc == USE_2s ? 						\
+	    ((p) >= appelInfo.space[appelInfo.semi_space].base && 	\
+	     (p) <= appelInfo.space[appelInfo.semi_space].lim) :	\
+	    (((p) >= appelInfo.oldbase && (p) <= appelInfo.oldlim) ||	\
+	     ((p) >= appelInfo.newbase && (p) <= appelInfo.newlim))	\
+    )
+
+#else
+#if defined(GCgn)
+#define validHeapPtr(p) \
+    (((p) >= genInfo.oldbase && (p) <= genInfo.oldlim) || \
+     ((p) >= genInfo.newgen[genInfo.curnew].newbase && (p) <= genInfo.newgen[genInfo.curnew].newlim) || \
+     ((p) >= genInfo.allocbase && (p) <= genInfo.alloclim))
+#else
+#define validHeapPtr(p) 0
+#endif
+#endif
+#endif
+#endif
+#endif
+
+
+void checkAStack(STG_NO_ARGS)
+{
+    PP_	stackptr;
+    P_	closurePtr;
+    P_	infoPtr;
+    I_	error = 0;
+
+    if (SuB > SpB + 1) {
+	fprintf(stderr, "SuB (%lx) > SpB (%lx)\n", (W_) SuB, (W_) SpB);
+	error = 1;
+    }
+    if (SuA < SpA) {
+	fprintf(stderr, "SuA (%lx) < SpA (%lx)\n", (W_) SuA, (W_) SpA);
+	error = 1;
+    }
+
+    for (stackptr = SpA;
+	 SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
+	 stackptr = stackptr + AREL(1)) {
+
+	closurePtr = (P_) *stackptr;
+
+	if (suspectPtr(closurePtr)) {
+	    fprintf(stderr, "Suspect heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n",
+		    (W_) SpA, (W_) stackptr, (W_) closurePtr);
+	    error = 1;
+
+	} else if (isHeapPtr(closurePtr) && ! validHeapPtr(closurePtr)) {
+
+	    fprintf(stderr, "Bad heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n",
+		    (W_) SpA, (W_) stackptr, (W_) closurePtr);
+	    error = 1;
+
+	} else {
+	    infoPtr = (P_) *closurePtr;
+
+	    if (suspectPtr(infoPtr)) {
+		fprintf(stderr, "Suspect info ptr on A stk; SpA %lx, sp %lx, closure %lx info %lx\n",
+		    (W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr);
+		error = 1;
+
+	    } else if ( ! validInfoPtr(infoPtr)) {
+		fprintf(stderr, "Bad info ptr in A stk; SpA %lx, sp %lx, closure %lx, info %lx\n",
+			(W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr/* , INFO_TYPE(infoPtr) */);
+		error = 1;
+	    }
+	}
+    }
+
+    if (error) abort();
+}
+
+#endif /* ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) ) */
+
+\end{code}
diff --git a/ghc/runtime/storage/SMcompacting.h b/ghc/runtime/storage/SMcompacting.h
new file mode 100644
index 0000000000..e64b8fd5bb
--- /dev/null
+++ b/ghc/runtime/storage/SMcompacting.h
@@ -0,0 +1,7 @@
+# line 4 "storage/SMcompacting.lh"
+extern void LinkRoots PROTO((P_ roots[], I_ rootno));
+extern void LinkAStack PROTO((PP_ stackA, PP_ botA));
+extern void LinkBStack PROTO((P_ stackB, P_ botB));
+extern I_ CountCAFs PROTO((P_ CAFlist));
+
+extern void LinkCAFs PROTO((P_ CAFlist));
diff --git a/ghc/runtime/storage/SMcompacting.lc b/ghc/runtime/storage/SMcompacting.lc
new file mode 100644
index 0000000000..60942d3b41
--- /dev/null
+++ b/ghc/runtime/storage/SMcompacting.lc
@@ -0,0 +1,234 @@
+\section[SM-compacting]{Compacting Collector Subroutines}
+
+This is a collection of C functions used in implementing the compacting
+collectors.
+
+The motivation for making this a separate file/section is twofold:
+
+1) It lets us focus on one thing.
+
+2) If we don't do this, there will be a huge amount of repetition
+   between the various GC schemes --- a maintenance nightmare.
+
+The second is the major motivation.  
+
+ToDo ADR: trash contents of other semispace after GC in debugging version
+
+\begin{code} 
+#if defined(GC1s) || defined(GCdu) || defined(GCap) || defined(GCgn)
+    /* to the end */
+
+#if defined(GC1s)
+
+#define  SCAN_REG_DUMP
+#include "SMinternal.h"
+REGDUMP(ScanRegDump);
+
+#else /* GCdu, GCap, GCgn */
+
+#define SCAV_REG_MAP
+#include "SMinternal.h"
+REGDUMP(ScavRegDump);
+
+#endif
+
+#include "SMcompacting.h"
+\end{code}
+
+\begin{code}
+void
+LinkRoots(roots, rootno)
+P_ roots[];
+I_ rootno;
+{
+    I_ root;
+
+    DEBUG_STRING("Linking Roots:");
+    for (root = 0; root < rootno; root++) {
+	LINK_LOCATION_TO_CLOSURE(&(roots[root]));
+    }
+}
+
+\end{code}
+
+\begin{code}
+
+#ifdef CONCURRENT
+void
+LinkSparks(STG_NO_ARGS)
+{
+    PP_ sparkptr;
+    int pool;
+
+    DEBUG_STRING("Linking Sparks:");
+    for (pool = 0; pool < SPARK_POOLS; pool++) {
+	for (sparkptr = PendingSparksHd[pool]; 
+          sparkptr < PendingSparksTl[pool]; sparkptr++) {
+	    LINK_LOCATION_TO_CLOSURE(sparkptr);
+	}
+    }
+}
+#endif
+
+\end{code}
+
+\begin{code}
+
+#ifdef PAR
+
+void
+LinkLiveGAs(base, bits)
+P_ base;
+BitWord *bits;
+{
+    GALA *gala;
+    GALA *next;
+    GALA *prev;
+    long _hp_word, bit_index, bit;
+
+    DEBUG_STRING("Linking Live GAs:");
+
+    for (gala = liveIndirections, prev = NULL; gala != NULL; gala = next) {
+	next = gala->next;
+	ASSERT(gala->ga.loc.gc.gtid == mytid);
+	if (gala->ga.weight != MAX_GA_WEIGHT) {
+	    LINK_LOCATION_TO_CLOSURE(&gala->la);
+	    gala->next = prev;
+	    prev = gala;
+	} else {
+	    /* Since we have all of the weight, this GA is no longer needed */
+	    W_ pga = PACK_GA(thisPE, gala->ga.loc.gc.slot);
+
+#ifdef FREE_DEBUG
+	    fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot);
+#endif
+	    gala->next = freeIndirections;
+	    freeIndirections->next = gala;
+	    (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
+#ifdef DEBUG
+	    gala->ga.weight = 0x0d0d0d0d;
+	    gala->la = (P_) 0xbadbad;
+#endif
+	}
+    }
+    liveIndirections = prev;
+
+    prepareFreeMsgBuffers();
+
+    for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
+	next = gala->next;
+	ASSERT(gala->ga.loc.gc.gtid != mytid);
+
+	_hp_word = gala->la - base;
+	bit_index = _hp_word / BITS_IN(BitWord);
+	bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1));
+	if (!(bits[bit_index] & bit)) {
+	    int pe = taskIDtoPE(gala->ga.loc.gc.gtid);
+	    W_ pga = PACK_GA(pe, gala->ga.loc.gc.slot);
+	    int i;
+
+	    (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
+	    freeRemoteGA(pe, &(gala->ga));
+	    gala->next = freeGALAList;
+	    freeGALAList = gala;
+	} else {
+	    LINK_LOCATION_TO_CLOSURE(&gala->la);
+	    gala->next = prev;
+	    prev = gala;
+	}
+    }
+    liveRemoteGAs = prev;
+
+    /* If we have any remaining FREE messages to send off, do so now */
+    sendFreeMessages();
+}
+
+#else
+
+\end{code}
+
+Note: no \tr{Link[AB]Stack} for ``parallel'' systems, because they
+don't have a single main stack.
+
+\begin{code}
+
+void
+LinkAStack(stackA, botA)
+PP_ stackA;
+PP_ botA;
+{
+    PP_ stackptr;
+
+    DEBUG_STRING("Linking A Stack:");
+    for (stackptr = stackA;
+      SUBTRACT_A_STK(stackptr, botA) >= 0;
+      stackptr = stackptr + AREL(1)) {
+	LINK_LOCATION_TO_CLOSURE(stackptr);
+    }
+}
+#endif /* PAR */
+\end{code}
+
+ToDo (Patrick?): Dont explicitly mark & compact unmarked Bstack frames
+
+\begin{code}   
+#if ! defined(PAR)
+void
+LinkBStack(stackB, botB)
+P_ stackB;
+P_ botB;			/* stackB points to topmost update frame */
+{
+    P_ updateFramePtr;
+
+    DEBUG_STRING("Linking B Stack:");
+    for (updateFramePtr = stackB;
+      SUBTRACT_B_STK(updateFramePtr, botB) > 0;
+      /* re-initialiser given explicitly */ ) {
+
+	P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE);
+
+	LINK_LOCATION_TO_CLOSURE(updateClosurePtr);
+
+	updateFramePtr = GRAB_SuB(updateFramePtr);
+    }
+}
+#endif /* not PAR */
+\end{code}
+
+\begin{code}
+I_
+CountCAFs(CAFlist)
+P_ CAFlist;
+{
+    I_ caf_no = 0;
+
+    for (caf_no = 0; CAFlist != NULL; CAFlist = (P_) IND_CLOSURE_LINK(CAFlist))
+	caf_no++;
+
+    return caf_no;
+}
+\end{code}
+
+\begin{code}
+void
+LinkCAFs(CAFlist)
+P_ CAFlist;
+{
+    DEBUG_STRING("Linking CAF Ptr Locations:");
+    while(CAFlist != NULL) {
+	DEBUG_LINK_CAF(CAFlist);
+	LINK_LOCATION_TO_CLOSURE(&IND_CLOSURE_PTR(CAFlist));
+	CAFlist = (P_) IND_CLOSURE_LINK(CAFlist);
+    }
+}
+
+\end{code}
+
+\begin{code}
+
+#ifdef PAR
+
+#endif /* PAR */
+
+#endif /* defined(_INFO_COMPACTING) */
+\end{code}
diff --git a/ghc/runtime/storage/SMcompacting.lh b/ghc/runtime/storage/SMcompacting.lh
new file mode 100644
index 0000000000..8740253057
--- /dev/null
+++ b/ghc/runtime/storage/SMcompacting.lh
@@ -0,0 +1,11 @@
+\section[SMcompacting-header]{Header file for SMcompacting}
+
+\begin{code}
+extern void LinkRoots PROTO((P_ roots[], I_ rootno));
+extern void LinkAStack PROTO((PP_ stackA, PP_ botA));
+extern void LinkBStack PROTO((P_ stackB, P_ botB));
+extern I_ CountCAFs PROTO((P_ CAFlist));
+
+extern void LinkCAFs PROTO((P_ CAFlist));
+\end{code}
+
diff --git a/ghc/runtime/storage/SMcopying.lc b/ghc/runtime/storage/SMcopying.lc
new file mode 100644
index 0000000000..98b1b79a8d
--- /dev/null
+++ b/ghc/runtime/storage/SMcopying.lc
@@ -0,0 +1,363 @@
+\section[SM-copying]{Copying Collector Subroutines}
+
+This is a collection of C functions used in implementing the copying
+collectors.
+
+The motivation for making this a separate file/section is twofold:
+
+1) It lets us focus on one thing.
+
+2) If we don't do this, there will be a huge amount of repetition
+   between the various GC schemes --- a maintenance nightmare.
+
+The second is the major motivation.  
+
+
+\begin{code} 
+#if defined(GC2s) || defined(GCdu) || defined(GCap) || defined(GCgn)
+    /* to the end */
+
+#define SCAV_REG_MAP
+#include "SMinternal.h"
+REGDUMP(ScavRegDump);
+
+#include "SMcopying.h"
+\end{code}
+
+Comment stolen from SMscav.lc: When doing a new generation copy
+collection for Appel's collector only evacuate references that point
+to the new generation.  OldGen must be set to point to the end of old
+space.
+
+\begin{code}
+#ifdef GCap
+
+#define MAYBE_EVACUATE_CLOSURE( closure )   \
+do {                                        \
+  P_ evac = (P_) (closure);                 \
+  if (evac > OldGen) {                      \
+    (closure) = EVACUATE_CLOSURE(evac);     \
+  }                                         \
+} while (0)
+
+#else
+
+#define MAYBE_EVACUATE_CLOSURE( closure )   \
+do {                                        \
+  P_ evac = (P_) (closure);                 \
+  (closure) = EVACUATE_CLOSURE(evac);       \
+} while (0)
+
+#endif
+\end{code}
+
+\begin{code}
+void
+SetCAFInfoTables( CAFlist )
+  P_ CAFlist;
+{
+  P_ CAFptr;
+
+  /* Set CAF info tables for evacuation */
+  DEBUG_STRING("Setting Evac & Upd CAFs:");
+  for (CAFptr = CAFlist; 
+       CAFptr != NULL;
+       CAFptr = (P_) IND_CLOSURE_LINK(CAFptr) ) {
+    INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
+  }
+}
+\end{code}
+
+\begin{code}
+void
+EvacuateRoots( roots, rootno )
+  P_ roots[];
+  I_ rootno;
+{
+  I_ root;
+
+  DEBUG_STRING("Evacuate (Reg) Roots:");
+  for (root = 0; root < rootno; root++) {
+    MAYBE_EVACUATE_CLOSURE( roots[root] );
+  }
+}
+\end{code}
+
+\begin{code}
+#ifdef CONCURRENT
+void
+EvacuateSparks(STG_NO_ARGS)
+{
+    PP_ sparkptr;
+    int pool;
+
+
+    DEBUG_STRING("Evacuate Sparks:");
+    for (pool = 0; pool < SPARK_POOLS; pool++) {
+	for (sparkptr = PendingSparksHd[pool];
+	  sparkptr < PendingSparksTl[pool]; sparkptr++) {
+	    MAYBE_EVACUATE_CLOSURE(*((PP_) sparkptr));
+	}
+    }
+}
+#endif
+\end{code}
+
+Note: no \tr{evacuate[AB]Stack} for ``parallel'' systems, because they
+don't have a single main stack.
+
+\begin{code}
+#ifndef PAR
+void
+EvacuateAStack( stackA, botA )
+  PP_ stackA;
+  PP_ botA; /* botA points to bottom-most word */
+{
+  PP_ stackptr;
+  
+  DEBUG_STRING("Evacuate A Stack:");
+  for (stackptr = stackA;
+       SUBTRACT_A_STK(stackptr, botA) >= 0;
+       stackptr = stackptr + AREL(1)) {
+    MAYBE_EVACUATE_CLOSURE( *((PP_) stackptr) );
+  }
+}
+#endif /* not PAR */
+\end{code}
+
+ToDo: Optimisation which squeezes out update frames which point to
+garbage closures.
+
+Perform collection first
+
+Then process B stack removing update frames (bot to top via pointer
+reversal) that reference garbage closues (test infoptr !=
+EVACUATED_INFOPTR)
+
+Otherwise closure is live update reference to to-space address
+
+\begin{code}
+#ifndef PAR
+void
+EvacuateBStack( stackB, botB, roots )
+  P_ stackB;
+  P_ botB;  /* botB points to bottom-most word */
+  I_ *roots;
+{
+  I_ bstk_roots;
+  P_ updateFramePtr;
+  P_ updatee;
+
+  DEBUG_STRING("Evacuate B Stack:");
+  bstk_roots = 0;
+  for (updateFramePtr = stackB;  /* stackB points to topmost update frame */
+       SUBTRACT_B_STK(updateFramePtr, botB) > 0;
+       updateFramePtr = GRAB_SuB(updateFramePtr)) {
+    
+    /* Evacuate the thing to be updated */
+    updatee = GRAB_UPDATEE(updateFramePtr);
+    MAYBE_EVACUATE_CLOSURE(updatee);
+    PUSH_UPDATEE(updateFramePtr, updatee);
+    bstk_roots++;
+  }
+  *roots = bstk_roots;
+}
+#endif /* not PAR */
+\end{code}
+
+When we do a copying collection, we want to evacuate all of the local entries
+in the GALA table for which there are outstanding remote pointers (i.e. for
+which the weight is not MAX_GA_WEIGHT.)
+
+\begin{code}
+
+#ifdef PAR
+
+void
+EvacuateLocalGAs(full)
+rtsBool full;
+{
+    GALA *gala;
+    GALA *next;
+    GALA *prev = NULL;
+
+    for (gala = liveIndirections; gala != NULL; gala = next) {
+	next = gala->next;
+	ASSERT(gala->ga.loc.gc.gtid == mytid);
+        if (gala->ga.weight != MAX_GA_WEIGHT) {
+	    /* Remote references exist, so we must evacuate the local closure */
+	    P_ old = gala->la;
+	    MAYBE_EVACUATE_CLOSURE(gala->la);
+	    if (!full && gala->preferred && gala->la != old) {
+		(void) removeHashTable(LAtoGALAtable, (W_) old, (void *) gala);
+		insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
+	    }
+	    gala->next = prev;
+	    prev = gala;
+	} else {
+	    /* Since we have all of the weight, this GA is no longer needed */
+	    W_ pga = PACK_GA(thisPE, gala->ga.loc.gc.slot);
+
+#ifdef FREE_DEBUG
+	    fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot);
+#endif
+	    gala->next = freeIndirections;
+	    freeIndirections = gala;
+	    (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
+	    if (!full && gala->preferred)
+		(void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
+#ifdef DEBUG
+	    gala->ga.weight = 0x0d0d0d0d;
+	    gala->la = (P_) 0xbadbad;
+#endif
+	}
+    }
+    liveIndirections = prev;
+}
+
+\end{code}
+
+\begin{code}
+
+EXTDATA_RO(Forward_Ref_info);
+
+void
+RebuildGAtables(full)
+rtsBool full;
+{
+    GALA *gala;
+    GALA *next;
+    GALA *prev;
+    P_ closure;
+
+    prepareFreeMsgBuffers();
+
+    for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
+	next = gala->next;
+	ASSERT(gala->ga.loc.gc.gtid != mytid);
+
+	closure = gala->la;
+
+	/*
+	 * If the old closure has not been forwarded, we let go.  Note that this
+	 * approach also drops global aliases for PLCs.
+	 */
+
+#if defined(GCgn) || defined(GCap)
+	if (closure > OldGen) {
+#endif
+	    if (!full && gala->preferred)
+		(void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
+
+	    /* Follow indirection chains to the end, just in case */
+	    while (IS_INDIRECTION(INFO_PTR(closure)))
+		closure = (P_) IND_CLOSURE_PTR(closure);
+
+	    /* Change later to incorporate a _FO bit in the INFO_TYPE for GCgn */
+#ifdef GCgn
+    fall over, until _FO bits are added
+#endif
+	    if (INFO_PTR(closure) != (W_) Forward_Ref_info) {
+		int pe = taskIDtoPE(gala->ga.loc.gc.gtid);
+		W_ pga = PACK_GA(pe, gala->ga.loc.gc.slot);
+		int i;
+
+		(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
+		freeRemoteGA(pe, &(gala->ga));
+		gala->next = freeGALAList;
+		freeGALAList = gala;
+	    } else {
+		/* Find the new space object */
+		closure = (P_) FORWARD_ADDRESS(closure);
+		gala->la = closure;
+
+		if (!full && gala->preferred)
+		    insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
+		gala->next = prev;
+		prev = gala;
+	    }
+#if defined(GCgn) || defined(GCap)
+	} else {
+	    /* Old generation, minor collection; just keep it */
+	    gala->next = prev;
+	    prev = gala;
+	}
+#endif
+    }
+    liveRemoteGAs = prev;
+
+    /* If we have any remaining FREE messages to send off, do so now */
+    sendFreeMessages();
+
+    if (full)
+	RebuildLAGAtable();
+}
+
+#endif
+
+\end{code}
+
+\begin{code}
+void
+Scavenge()
+{
+  DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
+  while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+  DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
+}
+\end{code}
+
+\begin{code}
+#ifdef GCdu
+
+void
+EvacuateCAFs( CAFlist )
+  P_ CAFlist;
+{
+  P_ CAFptr;
+
+  DEBUG_STRING("Evacuate CAFs:");
+  for (CAFptr = CAFlist; 
+       CAFptr != NULL;
+       CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+    EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
+  }
+}
+
+/* ToDo: put GCap EvacuateCAFs code here */
+
+#else /* not GCdu */
+
+void
+EvacAndScavengeCAFs( CAFlist, extra_words, roots )
+  P_ CAFlist;
+  I_ *extra_words;
+  I_ *roots;
+{
+  I_ caf_roots = 0;
+  P_ caf_start = ToHp;
+  P_ CAFptr;
+
+  DEBUG_STRING("Evacuate & Scavenge CAFs:");
+  for (CAFptr = CAFlist; 
+       CAFptr != NULL;
+       CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+
+    EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
+    caf_roots++;
+
+    DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
+    while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+    DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
+
+    /* this_extra_caf_words = ToHp - this_caf_start; */
+    /* ToDo: Report individual CAF space */
+  }
+  *extra_words = ToHp - caf_start;
+  *roots = caf_roots;
+}
+
+#endif /* !GCdu */
+
+#endif /* defined(_INFO_COPYING) */
+\end{code}
diff --git a/ghc/runtime/storage/SMcopying.lh b/ghc/runtime/storage/SMcopying.lh
new file mode 100644
index 0000000000..f2fbf140d7
--- /dev/null
+++ b/ghc/runtime/storage/SMcopying.lh
@@ -0,0 +1,15 @@
+\section[SMcopying-header]{Header file for SMcopying}
+
+\begin{code}
+extern void SetCAFInfoTables PROTO(( P_ CAFlist ));
+extern void EvacuateRoots PROTO(( P_ roots[], I_ rootno ));
+extern void EvacuateAStack PROTO(( PP_ stackA, PP_ botA ));
+extern void EvacuateBStack PROTO(( P_ stackB, P_ botB, I_ *roots ));
+extern void Scavenge PROTO(());
+
+#ifdef GCdu
+extern void EvacuateCAFs PROTO(( P_ CAFlist ));
+#else /* !GCdu */
+extern void EvacAndScavengeCAFs PROTO(( P_ CAFlist, I_ *extra_words, I_ *roots ));
+#endif /* !GCdu */
+\end{code}
diff --git a/ghc/runtime/storage/SMdu.lc b/ghc/runtime/storage/SMdu.lc
new file mode 100644
index 0000000000..abd39230f6
--- /dev/null
+++ b/ghc/runtime/storage/SMdu.lc
@@ -0,0 +1,291 @@
+***************************************************************************
+
+                      COMPACTING GARBAGE COLLECTION
+
+Global heap requirements as for 1s and 2s collectors.
+
+***************************************************************************
+
+ToDo: soft heap limits.
+
+\begin{code}
+
+#if defined(GCdu)
+
+#define SCAV_REG_MAP
+#include "SMinternal.h"
+#include "SMcopying.h"
+#include "SMcompacting.h"
+#include "SMextn.h"
+
+REGDUMP(ScavRegDump);
+
+dualmodeData dualmodeInfo = {TWO_SPACE_BOT,
+			     DEFAULT_RESID_TO_COMPACT,
+			     DEFAULT_RESID_FROM_COMPACT,
+			     {{0,0,0,"low->high"},
+			      {0,0,0,"high->low"},
+			      {0,0,0,"compacting"}},
+			     0, 0
+			    };
+
+P_ heap_space = 0;		/* Address of first word of slab 
+				   of memory allocated for heap */
+
+P_ hp_start;	        /* Value of Hp when reduction was resumed */
+
+I_
+initHeap( sm )
+    smInfo *sm;    
+{
+    if (heap_space == 0) { /* allocates if it doesn't already exist */
+
+	I_ semispaceSize = SM_word_heap_size / 2;
+
+	/* Allocate the roots space */
+	sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+
+	/* Allocate the heap */
+	heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+    
+	dualmodeInfo.modeinfo[TWO_SPACE_BOT].heap_words =
+	    dualmodeInfo.modeinfo[TWO_SPACE_TOP].heap_words = SM_word_heap_size;
+
+	dualmodeInfo.modeinfo[TWO_SPACE_BOT].base =
+	    HEAP_FRAME_BASE(heap_space, semispaceSize);
+	dualmodeInfo.modeinfo[TWO_SPACE_BOT].lim =
+	    HEAP_FRAME_LIMIT(heap_space, semispaceSize);
+	dualmodeInfo.modeinfo[TWO_SPACE_TOP].base =
+	    HEAP_FRAME_BASE(heap_space + semispaceSize, semispaceSize);
+	dualmodeInfo.modeinfo[TWO_SPACE_TOP].lim =
+	    HEAP_FRAME_LIMIT(heap_space + semispaceSize, semispaceSize);
+
+	dualmodeInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+	dualmodeInfo.bits      = (BitWord *)(heap_space + SM_word_heap_size) - dualmodeInfo.bit_words;
+
+	dualmodeInfo.modeinfo[COMPACTING].heap_words =
+	    SM_word_heap_size - dualmodeInfo.bit_words;
+	dualmodeInfo.modeinfo[COMPACTING].base =
+	    HEAP_FRAME_BASE(heap_space, SM_word_heap_size - dualmodeInfo.bit_words);
+	dualmodeInfo.modeinfo[COMPACTING].lim =
+	    HEAP_FRAME_LIMIT(heap_space, SM_word_heap_size - dualmodeInfo.bit_words);
+
+	stat_init("DUALMODE", "Collection", "  Mode  ");
+    }
+
+    sm->hp = hp_start = dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1;
+
+    if (SM_alloc_size) {
+	sm->hplim = sm->hp + SM_alloc_size;
+	SM_alloc_min = 0; /* No min; alloc size specified */
+
+	if (sm->hplim > dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) {
+	    fprintf(stderr, "Not enough heap for requested alloc size\n");
+	    return -1;
+	}
+    } else {
+	sm->hplim = dualmodeInfo.modeinfo[dualmodeInfo.mode].lim;
+    }
+
+    sm->CAFlist = NULL;
+
+#ifndef PAR
+    initExtensions( sm );
+#endif /* !PAR */
+
+    if (SM_trace) {
+	fprintf(stderr, "DUALMODE Heap: TS base, TS lim, TS base, TS lim, CM base, CM lim, CM bits, bit words\n                0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx\n",
+		(W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].base,
+		(W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].lim,
+		(W_) dualmodeInfo.modeinfo[TWO_SPACE_TOP].base,
+		(W_) dualmodeInfo.modeinfo[TWO_SPACE_TOP].lim,
+		(W_) dualmodeInfo.modeinfo[COMPACTING].base,
+		(W_) dualmodeInfo.modeinfo[COMPACTING].lim,
+		(W_) dualmodeInfo.bits, dualmodeInfo.bit_words);
+	fprintf(stderr, "DUALMODE Initial: mode %ld, base 0x%lx, lim 0x%lx\n                         hp 0x%lx, hplim 0x%lx, free %lu\n",
+		(W_) dualmodeInfo.mode,
+		(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
+		(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+    }
+
+    return 0;
+}
+
+I_
+collectHeap(reqsize, sm, do_full_collection)
+    W_ reqsize;
+    smInfo *sm;
+    rtsBool do_full_collection;
+{
+    I_  start_mode;
+
+    I_ free_space,	/* No of words of free space following GC */
+	alloc, 		/* Number of words allocated since last GC */
+	resident,	/* Number of words remaining after GC */
+	bstk_roots;	/* Number of update frames on B stack */
+    StgFloat residency;    /* % Words remaining after GC */
+
+    fflush(stdout);     /* Flush stdout at start of GC */
+    SAVE_REGS(&ScavRegDump); /* Save registers */
+
+    if (SM_trace)
+	fprintf(stderr, "DUALMODE Start: mode %ld, base 0x%lx, lim 0x%lx\n                      hp 0x%lx, hplim 0x%lx, req %lu\n",
+		dualmodeInfo.mode,
+		(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
+		(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
+
+    alloc = sm->hp - hp_start;
+    stat_startGC(alloc);
+
+    start_mode = dualmodeInfo.mode;
+    if (start_mode == COMPACTING) { 
+
+	/* PERFORM COMPACTING COLLECTION */
+
+	/* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
+	RESTORE_REGS(&ScavRegDump);
+
+	markHeapRoots(sm, sm->CAFlist, 0,
+		      dualmodeInfo.modeinfo[COMPACTING].base,
+		      dualmodeInfo.modeinfo[COMPACTING].lim,
+		      dualmodeInfo.bits);
+
+	SAVE_REGS(&ScavRegDump);
+	/* end of bracket */
+
+#ifndef PAR
+	sweepUpDeadMallocPtrs(sm->MallocPtrList, 
+			      dualmodeInfo.modeinfo[COMPACTING].base,
+			      dualmodeInfo.bits);
+#endif
+	LinkCAFs(sm->CAFlist);
+
+	LinkRoots( sm->roots, sm->rootno );
+#ifdef CONCURRENT
+	LinkSparks();
+#endif
+#ifdef PAR
+	LinkLiveGAs(dualmodeInfo.modeinfo[COMPACTING].base, dualmodeInfo.bits);
+#else
+        DEBUG_STRING("Linking Stable Pointer Table:");
+        LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
+	LinkAStack( MAIN_SpA, stackInfo.botA );
+	LinkBStack( MAIN_SuB, stackInfo.botB );
+#endif
+
+	/* Do Inplace Compaction */
+	/* Returns start of next closure, -1 gives last allocated word */
+	
+	sm->hp = Inplace_Compaction(dualmodeInfo.modeinfo[COMPACTING].base,
+				    dualmodeInfo.modeinfo[COMPACTING].lim,
+				    0, 0,
+				    dualmodeInfo.bits,
+				    dualmodeInfo.bit_words
+#ifndef PAR
+				    ,&(sm->MallocPtrList)
+#endif
+				    ) - 1;
+
+    } else {
+
+	/* COPYING COLLECTION */
+
+	dualmodeInfo.mode = NEXT_SEMI_SPACE(start_mode);
+	ToHp = dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1;
+	Scav = dualmodeInfo.modeinfo[dualmodeInfo.mode].base;
+	       /* Point to (info field of) first closure */
+    
+	SetCAFInfoTables( sm->CAFlist );
+	EvacuateCAFs( sm->CAFlist );
+#ifdef PAR
+	EvacuateLocalGAs(rtsTrue);
+#else
+	evacSPTable( sm );
+#endif /* PAR */
+	EvacuateRoots( sm->roots, sm->rootno );
+#ifdef CONCURRENT
+	EvacuateSparks();
+#endif
+#ifndef PAR
+	EvacuateAStack( MAIN_SpA, stackInfo.botA );
+	EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
+#endif /* !PAR */
+
+	Scavenge();
+
+#ifdef PAR
+        RebuildGAtables(rtsTrue);
+#else
+	reportDeadMallocPtrs(sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+#endif /* PAR */
+
+	sm->hp = hp_start = ToHp;  /* Last allocated word */
+    }
+
+    /* Use residency to determine if a change in mode is required */
+
+    resident = sm->hp - (dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1);
+    residency = resident / (StgFloat) SM_word_heap_size;
+    DO_MAX_RESIDENCY(resident); /* stats only */
+
+    if ((start_mode == TWO_SPACE_TOP) &&
+	(residency > dualmodeInfo.resid_to_compact)) {
+	DEBUG_STRING("Changed Mode: Two Space => Compacting");
+	dualmodeInfo.mode = COMPACTING;
+
+	/* Zero bit vector for marking phase at next collection */
+	{ BitWord *ptr = dualmodeInfo.bits,
+	          *end = dualmodeInfo.bits + dualmodeInfo.bit_words;
+	  while (ptr < end) { *(ptr++) = 0; };
+    }
+
+    } else if ((start_mode == COMPACTING) &&
+	(residency < dualmodeInfo.resid_from_compact)) {
+	DEBUG_STRING("Changed Mode: Compacting => Two Space");
+	dualmodeInfo.mode = TWO_SPACE_BOT;
+    }
+
+    if (SM_alloc_size) {
+	sm->hplim = sm->hp + SM_alloc_size;
+	if (sm->hplim > dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) {
+	    free_space = 0;
+	} else {
+	    free_space = SM_alloc_size;
+	}
+    } else {
+	sm->hplim = dualmodeInfo.modeinfo[dualmodeInfo.mode].lim;
+	free_space = sm->hplim - sm->hp;
+    }
+
+    hp_start = sm->hp;
+
+    stat_endGC(alloc, dualmodeInfo.modeinfo[start_mode].heap_words,
+	       resident, dualmodeInfo.modeinfo[start_mode].name);
+
+    if (SM_trace)
+	fprintf(stderr, "DUALMODE Done: mode %ld, base 0x%lx, lim 0x%lx\n                         hp 0x%lx, hplim 0x%lx, free %lu\n",
+		dualmodeInfo.mode,
+		(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
+		(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) ((sm->hplim - sm->hp) * sizeof(W_)));
+
+#ifdef DEBUG
+    /* To help flush out bugs, we trash the part of the heap from
+       which we're about to start allocating. */
+    TrashMem(sm->hp+1, sm->hplim);
+#endif /* DEBUG */
+
+    RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+
+    if ((SM_alloc_min > free_space) || (reqsize > free_space))
+	return GC_HARD_LIMIT_EXCEEDED;	/* Heap exhausted */
+    else 
+	return GC_SUCCESS;		/* Heap OK */
+}
+
+#endif /* GCdu */
+
+\end{code}
+
diff --git a/ghc/runtime/storage/SMevac.lc b/ghc/runtime/storage/SMevac.lc
new file mode 100644
index 0000000000..0eab98b906
--- /dev/null
+++ b/ghc/runtime/storage/SMevac.lc
@@ -0,0 +1,1203 @@
+%****************************************************************************
+
+The files SMevac.lc and SMscav.lhc contain the basic routines required
+for two-space copying garbage collection.
+
+Two files are required as the evac routines are conventional call/return
+routines while the scavenge routines are continuation routines.
+
+This file SMevac.lc contains the evacuation routines ...
+
+See SMscav.lhc for calling convention documentation.
+
+%****************************************************************************
+
+\begin{code}
+#define  SCAV_REG_MAP
+#include "SMinternal.h"
+
+#if defined(_INFO_COPYING)
+
+/* Moves ToHp to point at the info pointer of the new to-space closure */
+#define START_ALLOC(size)     ToHp += 1
+
+/* Moves ToHp to point to the last word allocated in to-space */
+#define FINISH_ALLOC(size)    ToHp += (FIXED_HS-1) + (size)
+
+
+/* Copy the ith word (starting at 0) */
+#define COPY_WORD(position)    ToHp[position] = evac[position]
+
+/* Copy the ith ptr (starting at 0), adjusting by offset */
+#define ADJUST_WORD(pos,off)   ((PP_)ToHp)[pos] = ((PP_)evac)[pos] + (off)
+
+/* Copy the nth free var word in a SPEC closure (starting at 1) */
+#define SPEC_COPY_FREE_VAR(n)  COPY_WORD((SPEC_HS-1) + (n))
+
+#if FIXED_HS == 1
+#define COPY_FIXED_HDR         COPY_WORD(0)
+#else
+#if FIXED_HS == 2
+#define COPY_FIXED_HDR         COPY_WORD(0);COPY_WORD(1)
+#else
+#if FIXED_HS == 3
+#define COPY_FIXED_HDR         COPY_WORD(0);COPY_WORD(1);COPY_WORD(2)
+#else
+/* I don't think this will be needed (ToDo: #error?) */
+#endif /* FIXED_HS != 1, 2, or 3 */
+#endif
+#endif
+
+
+/*** DEBUGGING MACROS ***/
+
+#if defined(_GC_DEBUG)
+
+#define DEBUG_EVAC(sizevar) \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \
+		evac, ToHp, INFO_PTR(evac), sizevar)
+
+#define DEBUG_EVAC_DYN   \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Dyn info 0x%lx, size %lu\n", \
+		evac, ToHp, INFO_PTR(evac), DYN_CLOSURE_SIZE(evac))
+
+#define DEBUG_EVAC_TUPLE \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Tuple info 0x%lx, size %lu\n", \
+		evac, ToHp, INFO_PTR(evac), TUPLE_CLOSURE_SIZE(evac))
+
+#define DEBUG_EVAC_MUTUPLE \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, MuTuple info 0x%lx, size %lu\n", \
+		evac, ToHp, INFO_PTR(evac), MUTUPLE_CLOSURE_SIZE(evac))
+
+#define DEBUG_EVAC_DATA  \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Data info 0x%lx, size %lu\n", \
+		evac, ToHp, INFO_PTR(evac), DATA_CLOSURE_SIZE(evac))
+
+#define DEBUG_EVAC_BH(sizevar) \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BH info 0x%lx, size %ld\n", \
+		evac, ToHp, INFO_PTR(evac), sizevar)
+
+#define DEBUG_EVAC_FORWARD \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Forward 0x%lx -> 0x%lx, info 0x%lx\n", \
+		evac, FORWARD_ADDRESS(evac), INFO_PTR(evac))
+   
+#define DEBUG_EVAC_IND1 \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
+		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
+
+#define DEBUG_EVAC_IND2 \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Indirection Done -> 0x%lx\n", evac)
+
+#define DEBUG_EVAC_PERM_IND \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Permanent Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
+		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
+
+#define DEBUG_EVAC_CAF_EVAC1 \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Caf 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
+		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
+
+#define DEBUG_EVAC_CAF_EVAC2 \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Caf Done -> 0x%lx\n", evac)
+
+#define DEBUG_EVAC_CAF_RET \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Caf 0x%lx -> 0x%lx, info 0x%lx\n", \
+		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
+
+#define DEBUG_EVAC_STAT \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Static 0x%lx -> 0x%lx, info 0x%lx\n", \
+		evac, evac, INFO_PTR(evac))
+
+#define DEBUG_EVAC_CONST \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: Const 0x%lx -> 0x%lx, info 0x%lx\n", \
+		evac, CONST_STATIC_CLOSURE(INFO_PTR(evac)), INFO_PTR(evac))
+
+#define DEBUG_EVAC_CHARLIKE \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: CharLike (%lx) 0x%lx -> 0x%lx, info 0x%lx\n", \
+		evac, CHARLIKE_VALUE(evac), CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac)), INFO_PTR(evac))
+
+#define	DEBUG_EVAC_INTLIKE_TO_STATIC \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: IntLike to Static (%ld) 0x%lx -> 0x%lx, info 0x%lx\n", \
+		INTLIKE_VALUE(evac), evac, INTLIKE_CLOSURE(INTLIKE_VALUE(evac)), INFO_PTR(evac))
+
+#define DEBUG_EVAC_TO_OLD \
+    if (SM_trace & 2) \
+	fprintf(stderr, "Old ")
+
+#define DEBUG_EVAC_TO_NEW \
+    if (SM_trace & 2) \
+	fprintf(stderr, "New ")
+
+#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new) \
+    if (SM_trace & 2) \
+	fprintf(stderr, "  OldRoot: 0x%lx -> Old 0x%lx (-> New 0x%lx)\n", \
+			 evac, oldind, newevac)
+
+#define DEBUG_EVAC_OLDROOT_FORWARD \
+    if (SM_trace & 2) { \
+	fprintf(stderr, "Evac: OldRoot Forward 0x%lx -> Old 0x%lx ", evac, FORWARD_ADDRESS(evac)); \
+	if (! InOldGen(Scav)) fprintf(stderr, "-> New 0x%lx ", IND_CLOSURE_PTR(FORWARD_ADDRESS(evac))); \
+        fprintf(stderr, "info 0x%lx\n", INFO_PTR(evac)); \
+    }
+
+#ifdef CONCURRENT
+#define DEBUG_EVAC_BQ \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BQ info 0x%lx, size %lu\n", \
+		evac, ToHp, INFO_PTR(evac), BQ_CLOSURE_SIZE(evac))
+
+#define DEBUG_EVAC_TSO(size) \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac TSO: 0x%lx -> 0x%lx, size %ld\n", \
+		evac, ToHp, size)
+
+#define DEBUG_EVAC_STKO(a,b) \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac StkO: 0x%lx -> 0x%lx, size %ld (A), %ld (B)\n", \
+		evac, ToHp, a, b)
+
+# ifdef PAR
+#  define DEBUG_EVAC_BF \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BF info 0x%lx, size %lu\n", \
+		evac, ToHp, INFO_PTR(evac), BF_CLOSURE_SIZE(dummy))
+# endif
+
+#endif
+
+#else
+
+#define DEBUG_EVAC(size)
+#define DEBUG_EVAC_DYN
+#define DEBUG_EVAC_TUPLE
+#define DEBUG_EVAC_MUTUPLE
+#define DEBUG_EVAC_DATA
+#define DEBUG_EVAC_BH(size)
+#define DEBUG_EVAC_FORWARD
+#define DEBUG_EVAC_IND1
+#define DEBUG_EVAC_IND2
+#define DEBUG_EVAC_PERM_IND
+#define DEBUG_EVAC_CAF_EVAC1
+#define DEBUG_EVAC_CAF_EVAC2
+#define DEBUG_EVAC_CAF_RET
+#define DEBUG_EVAC_STAT
+#define DEBUG_EVAC_CONST
+#define DEBUG_EVAC_CHARLIKE
+#define	DEBUG_EVAC_INTLIKE_TO_STATIC
+#define DEBUG_EVAC_TO_OLD
+#define DEBUG_EVAC_TO_NEW
+#define DEBUG_EVAC_OLDROOT_FORWARD
+#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new)
+
+#ifdef CONCURRENT
+# define DEBUG_EVAC_BQ
+# define DEBUG_EVAC_TSO(size)
+# define DEBUG_EVAC_STKO(s,size)
+# ifdef PAR
+#  define DEBUG_EVAC_BF
+# endif
+#endif
+
+#endif /* not _GC_DEBUG */
+
+
+#if defined(GCgn)
+
+/* Evacuation with Promotion -- Have to decide if we promote ! */
+/* This is done by fiddling the ToHp pointer before calling    */
+/* the real _do_Evacute code, passing reqd forward ref info    */
+
+/* Is a heap ptr in the old generation ? */
+#define InOldGen(hpptr)    (((P_)(hpptr)) <= OldGen)
+
+/* Should we promote to the old generation ? */
+#define ShouldPromote(evac) (((P_)(evac)) <  AllocGen)
+
+
+/*** Real Evac Code -- passed closure & forward ref info ***/
+
+#define EVAC_FN(suffix) \
+	P_ CAT2(_do_Evacuate_,suffix)(evac, forward_info) \
+	P_ evac; P_ forward_info;
+
+
+/*** Evac Decision Code -- calls real evac code ***/
+
+extern P_ _Evacuate_Old_to_New();
+
+#define GEN_EVAC_CODE(suffix) 			\
+    P_ CAT2(_Evacuate_,suffix)(evac) 		\
+        P_ evac;                     		\
+    {						\
+        P_ newevac, tmp;               		\
+    	if (ShouldPromote(evac)) {		\
+	    DEBUG_EVAC_TO_OLD;			\
+	    tmp = ToHp;	ToHp = OldHp;		\
+	    newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_Old_info); \
+	    OldHp = ToHp; ToHp = tmp;		\
+    	} else {				\
+	    DEBUG_EVAC_TO_NEW;			\
+	    newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_New_info); \
+						\
+	    /* Check if new gen closure is scavenged from the old gen */ \
+	    if (InOldGen(Scav)) {               \
+	    	newevac = (P_) _Evacuate_Old_to_New(newevac, evac); \
+	    }					\
+    	}					\
+    	return newevac;				\
+    }
+
+
+/*** FORWARD REF STUFF ***/
+
+/*** Setting Forward Ref: grab argument passed to evac code ***/
+
+/* Note that writing in the forwarding address trashes part of the
+   closure.  This is normally fine since, if we want the data, we'll
+   have made a copy of it.  
+
+   But, Malloc Pointer closures are special: we have to make sure that
+   we don't damage either the linked list (which will include both
+   copied and uncopied Malloc ptrs) or the data (which we must report
+   to the outside world).  Malloc Ptr closures are carefully designed
+   to have a little extra space in them that can be safely
+   overwritten. [ADR] 
+*/
+
+#define SET_FORWARD_REF(closure, forw) \
+            SET_INFO_PTR(closure,forward); /* arg passed to evac function */ \
+            FORWARD_ADDRESS(closure) = (W_)(forw)
+
+
+P_
+_Evacuate_Old_Forward_Ref(evac)
+P_ evac;
+{
+    /* Forward ref to old generation -- just return */
+    DEBUG_EVAC_FORWARD;
+
+    evac = (P_) FORWARD_ADDRESS(evac);
+    return(evac);
+}
+
+P_
+_Evacuate_New_Forward_Ref(evac)
+P_ evac;
+{
+    /* Forward ref to new generation -- check scavenged from the old gen */
+    DEBUG_EVAC_FORWARD;
+
+    if (InOldGen(Scav)) {
+    	evac = (P_) _Evacuate_Old_to_New(FORWARD_ADDRESS(evac), evac);
+    } else {
+        evac = (P_) FORWARD_ADDRESS(evac);
+    }
+    return(evac);
+}
+
+P_
+_Evacuate_OldRoot_Forward(evac)
+P_ evac;
+{
+    /* Forward ref to old generation root -- return old root or new gen closure */
+    DEBUG_EVAC_OLDROOT_FORWARD;
+
+    /* grab old generation root */
+    evac = (P_) FORWARD_ADDRESS(evac);
+
+    /* if scavenging new generation return the new generation
+       closure rather than the old generation root */
+    if (! InOldGen(Scav)) {
+	evac = (P_) IND_CLOSURE_PTR(evac);
+    }
+
+    return(evac);
+}
+
+EXTDATA_RO(Forward_Ref_New_info);
+EXTDATA_RO(Forward_Ref_Old_info);
+EXTDATA_RO(OldRoot_Forward_Ref_info);
+
+/*** Old Gen Reference to New Gen Closure ***/
+
+P_
+_Evacuate_Old_to_New(newevac, evac)
+P_ newevac, evac;
+{
+    /* New generation closure referenced from the old generation           */
+    /*    allocate old generation indirection to newevac                   */
+    /*    reset forward reference in original allocation area to oldind    */
+    /*      evacuating this should return the old root or the new gen      */
+    /*      closure depending if referenced from the old generation        */
+    /*    return oldind as evacuated location                              */
+    /*      reference from oldgen will be to this oldind closure           */
+
+    P_ oldind = OldHp + 1;                     /* see START_ALLOC  */
+    OldHp = oldind + (FIXED_HS-1) + MIN_UPD_SIZE;  /* see FINISH_ALLOC */
+
+    DEBUG_EVAC_OLD_TO_NEW(oldind, evac, newevac);
+    
+    INFO_PTR(evac) = (W_) OldRoot_Forward_Ref_info;
+    FORWARD_ADDRESS(evac) = (W_)oldind;
+	    
+    INFO_PTR(oldind) = (W_) OldRoot_info;
+    IND_CLOSURE_PTR(oldind) = (W_) newevac;
+    IND_CLOSURE_LINK(oldind) = (W_) genInfo.OldInNew;
+    genInfo.OldInNew = oldind;
+    genInfo.OldInNewno++;
+
+    return oldind;
+}
+
+#define PROMOTE_MUTABLE(evac)			    \
+    if (InOldGen(evac)) {			    \
+	MUT_LINK(evac) = (W_) genInfo.PromMutables; \
+	genInfo.PromMutables = (P_) evac;	    \
+    }
+
+#else /* ! GCgn */
+
+#if defined(GCap)
+
+#define PROMOTE_MUTABLE(evac)			    \
+    MUT_LINK(evac) = (W_) appelInfo.PromMutables;   \
+    appelInfo.PromMutables = (P_) evac;
+
+#else
+
+#define PROMOTE_MUTABLE(evac)
+
+#endif /* GCap */
+
+/*** Real Evac Code -- simply passed closure ***/
+
+#define EVAC_FN(suffix) \
+	P_ CAT2(_Evacuate_,suffix)(evac) \
+	P_ evac;
+
+/*** FORWARD REF STUFF ***/
+
+#define SET_FORWARD_REF(closure, forw) \
+            SET_INFO_PTR(closure, Forward_Ref_info); \
+            FORWARD_ADDRESS(closure) = (W_) (forw)
+
+P_
+_Evacuate_Forward_Ref(evac)
+P_ evac;
+{
+    DEBUG_EVAC_FORWARD;
+    evac = (P_) FORWARD_ADDRESS(evac);
+    return(evac);
+}
+
+EXTDATA_RO(Forward_Ref_info);
+
+#endif /* ! GCgn */
+
+
+/*** SPECIALISED CODE ***/
+
+/* Note: code for evacuating selectors is given near that for Ind(irections) */
+
+EVAC_FN(1)
+{
+    START_ALLOC(1);
+
+    DEBUG_EVAC(1);
+    COPY_FIXED_HDR;
+    SPEC_COPY_FREE_VAR(1);
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(1);
+    return(evac);
+}
+
+EVAC_FN(2)
+{
+    START_ALLOC(2);
+    DEBUG_EVAC(2);
+    COPY_FIXED_HDR;
+    SPEC_COPY_FREE_VAR(1);
+    SPEC_COPY_FREE_VAR(2);
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(2);
+    return(evac);
+}
+
+EVAC_FN(3)
+{
+    START_ALLOC(3);
+    DEBUG_EVAC(3);
+    COPY_FIXED_HDR;
+    SPEC_COPY_FREE_VAR(1);
+    SPEC_COPY_FREE_VAR(2);
+    SPEC_COPY_FREE_VAR(3);
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(3);
+    return(evac);
+}
+
+EVAC_FN(4)
+{
+    START_ALLOC(4);
+    DEBUG_EVAC(4);
+    COPY_FIXED_HDR;
+    SPEC_COPY_FREE_VAR(1);
+    SPEC_COPY_FREE_VAR(2);
+    SPEC_COPY_FREE_VAR(3);
+    SPEC_COPY_FREE_VAR(4);
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(4);
+    return(evac);
+}
+
+EVAC_FN(5)
+{
+    START_ALLOC(5);
+    DEBUG_EVAC(5);
+    COPY_FIXED_HDR;
+    SPEC_COPY_FREE_VAR(1);
+    SPEC_COPY_FREE_VAR(2);
+    SPEC_COPY_FREE_VAR(3);
+    SPEC_COPY_FREE_VAR(4);
+    SPEC_COPY_FREE_VAR(5);
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(5);
+    return(evac);
+}
+
+#define BIG_SPEC_EVAC_FN(n) \
+EVAC_FN(n) \
+{ \
+    int i; \
+    START_ALLOC(n); \
+    DEBUG_EVAC(n); \
+    COPY_FIXED_HDR; \
+    for (i = 1; i <= n; i++) { SPEC_COPY_FREE_VAR(i); } \
+    SET_FORWARD_REF(evac,ToHp); \
+    evac = ToHp; \
+    FINISH_ALLOC(n); \
+    return(evac); \
+}
+
+/* instantiate for 6--12 */
+BIG_SPEC_EVAC_FN(6)
+BIG_SPEC_EVAC_FN(7)
+BIG_SPEC_EVAC_FN(8)
+BIG_SPEC_EVAC_FN(9)
+BIG_SPEC_EVAC_FN(10)
+BIG_SPEC_EVAC_FN(11)
+BIG_SPEC_EVAC_FN(12)
+
+\end{code}
+
+A @SPEC_RBH@ must be at least size @MIN_UPD_SIZE@ (Who are we fooling?
+This means 2), and the first word after the fixed header is a
+@MUT_LINK@.  The second word is a pointer to a blocking queue.
+Remaining words are the same as the underlying @SPEC@ closure.  Unlike
+their @SPEC@ cousins, @SPEC_RBH@ closures require special handling for
+generational collectors, because the blocking queue is a mutable
+field.
+
+We don't expect to have a lot of these, so I haven't unrolled the
+first five instantiations of the macro, but feel free to do so if it
+turns you on.
+
+\begin{code}
+
+#ifdef PAR
+
+#define SPEC_RBH_EVAC_FN(n) \
+EVAC_FN(CAT2(RBH_,n)) \
+{ \
+    int i; \
+    START_ALLOC(n); \
+    DEBUG_EVAC(n); \
+    COPY_FIXED_HDR; \
+    for (i = 0; i < n - 1; i++) { COPY_WORD(SPEC_RBH_HS + i); } \
+    SET_FORWARD_REF(evac,ToHp); \
+    evac = ToHp; \
+    FINISH_ALLOC(n); \
+    PROMOTE_MUTABLE(evac);\
+    return(evac); \
+}
+
+/* instantiate for 2--12 */
+SPEC_RBH_EVAC_FN(2)
+SPEC_RBH_EVAC_FN(3)
+SPEC_RBH_EVAC_FN(4)
+SPEC_RBH_EVAC_FN(5)
+SPEC_RBH_EVAC_FN(6)
+SPEC_RBH_EVAC_FN(7)
+SPEC_RBH_EVAC_FN(8)
+SPEC_RBH_EVAC_FN(9)
+SPEC_RBH_EVAC_FN(10)
+SPEC_RBH_EVAC_FN(11)
+SPEC_RBH_EVAC_FN(12)
+
+#endif
+
+#ifndef PAR
+EVAC_FN(MallocPtr)
+{
+    START_ALLOC(MallocPtr_SIZE);
+    DEBUG_EVAC(MallocPtr_SIZE);
+
+#if defined(_GC_DEBUG)
+    if (SM_trace & 16) {
+      printf("DEBUG: Evacuating MallocPtr(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]);
+      printf(" Data = %x, Next = %x\n", 
+	     MallocPtr_CLOSURE_DATA(evac), MallocPtr_CLOSURE_LINK(evac) );
+    }
+#endif
+
+    COPY_FIXED_HDR;
+
+    SET_FORWARD_REF(evac,ToHp);
+    MallocPtr_CLOSURE_DATA(ToHp) = MallocPtr_CLOSURE_DATA(evac);
+    MallocPtr_CLOSURE_LINK(ToHp) = MallocPtr_CLOSURE_LINK(evac);
+
+#if defined(_GC_DEBUG)
+    if (SM_trace & 16) {
+      printf("DEBUG: Evacuated  MallocPtr(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]);
+      printf(" Data = %x, Next = %x\n", 
+	     MallocPtr_CLOSURE_DATA(ToHp), MallocPtr_CLOSURE_LINK(ToHp) );
+    }
+#endif
+
+    evac = ToHp;
+    FINISH_ALLOC(MallocPtr_SIZE);
+    return(evac);
+}
+#endif /* !PAR */
+
+/*** GENERIC CASE CODE ***/
+
+EVAC_FN(S)
+{
+    I_ count = FIXED_HS - 1;
+    I_ size = GEN_CLOSURE_SIZE(evac);
+
+    START_ALLOC(size);
+    DEBUG_EVAC(size);
+    COPY_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	COPY_WORD(count);
+    }
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(size);
+    return(evac);
+}
+
+\end{code}
+
+Like a @SPEC_RBH@, a @GEN_RBH@ must be at least @MIN_UPD_SIZE@, and
+the first word after the fixed header is a @MUT_LINK@.  The second
+word is a pointer to a blocking queue.  Remaining words are the same
+as the underlying @GEN@ closure.
+
+\begin{code}
+
+#ifdef PAR
+EVAC_FN(RBH_S)
+{
+    I_ count = GEN_RBH_HS - 1;
+    I_ size = GEN_RBH_CLOSURE_SIZE(evac);
+
+    START_ALLOC(size);
+    DEBUG_EVAC(size);
+    COPY_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	COPY_WORD(count);
+    }
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(size);
+
+    PROMOTE_MUTABLE(evac);
+
+    return(evac);
+}
+#endif
+
+/*** DYNAMIC CLOSURE -- SIZE & PTRS STORED IN CLOSURE ***/
+
+EVAC_FN(Dyn)
+{
+    I_ count = FIXED_HS - 1;
+    I_ size = DYN_CLOSURE_SIZE(evac);  /* Includes size and no-of-ptrs fields */
+
+    START_ALLOC(size);
+    DEBUG_EVAC_DYN;
+    COPY_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	COPY_WORD(count);
+    }
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(size);
+    return(evac);
+}
+
+/*** TUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/
+
+EVAC_FN(Tuple)
+{
+    I_ count = FIXED_HS - 1; 
+    I_ size = TUPLE_CLOSURE_SIZE(evac);
+
+    START_ALLOC(size);
+    DEBUG_EVAC_TUPLE;
+    COPY_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	COPY_WORD(count);
+    }
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(size);
+    return(evac);
+}
+
+/*** MUTUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/
+/*               Only if special GC treatment required             */
+
+#ifdef GC_MUT_REQUIRED
+EVAC_FN(MuTuple)
+{
+    I_ count = FIXED_HS - 1; 
+    I_ size = MUTUPLE_CLOSURE_SIZE(evac);
+
+    START_ALLOC(size);
+    DEBUG_EVAC_MUTUPLE;
+
+    COPY_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	COPY_WORD(count);
+    }
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(size);
+
+    /* Add to OldMutables list (if evacuated to old generation) */
+    PROMOTE_MUTABLE(evac);
+
+    return(evac);
+}
+#endif /* GCgn or GCap */
+
+
+/*** DATA CLOSURE -- SIZE STORED IN CLOSURE -- NO POINTERS ***/
+
+EVAC_FN(Data)
+{
+    I_ count = FIXED_HS - 1; 
+    I_ size = DATA_CLOSURE_SIZE(evac);
+
+    START_ALLOC(size);
+    DEBUG_EVAC_DATA;
+    COPY_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	COPY_WORD(count);
+    }
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(size);
+    return(evac);
+}
+
+
+/*** STATIC CLOSURE CODE ***/
+
+/* Evacuation: Just return static address (no copying required)
+               Evac already contains this address -- just return   */
+/* Scavenging: Static closures should never be scavenged */
+
+P_
+_Evacuate_Static(evac)
+P_ evac;
+{
+    DEBUG_EVAC_STAT;
+    return(evac);
+}
+
+void
+_Scavenge_Static(STG_NO_ARGS)
+{
+    fprintf(stderr,"Called _Scavenge_Static: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
+    abort();
+}
+
+
+/*** BLACK HOLE CODE ***/
+
+EVAC_FN(BH_U)
+{
+    START_ALLOC(MIN_UPD_SIZE);
+    DEBUG_EVAC_BH(MIN_UPD_SIZE);
+    COPY_FIXED_HDR;
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(MIN_UPD_SIZE);
+    return(evac);
+}
+
+EVAC_FN(BH_N)
+{
+    START_ALLOC(MIN_NONUPD_SIZE);
+    DEBUG_EVAC_BH(MIN_NONUPD_SIZE);
+    COPY_FIXED_HDR;
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(MIN_NONUPD_SIZE);
+    return(evac);
+}
+
+/*** INDIRECTION CODE ***/
+
+/* Evacuation: Evacuate closure pointed to */
+
+P_
+_Evacuate_Ind(evac)
+P_ evac;
+{
+    DEBUG_EVAC_IND1;
+    evac = (P_) IND_CLOSURE_PTR(evac);
+
+#if defined(GCgn) || defined(GCap)
+    if (evac > OldGen)  /* Only evacuate new gen with generational collector */
+	evac = EVACUATE_CLOSURE(evac);
+#else
+    evac = EVACUATE_CLOSURE(evac);
+#endif
+
+    DEBUG_EVAC_IND2;
+    return(evac);
+
+    /* This will generate a stack of returns for a chain of indirections!
+       However chains can only be 2 long.
+   */
+}
+
+#ifdef USE_COST_CENTRES
+#undef PI
+EVAC_FN(PI)
+{
+    START_ALLOC(MIN_UPD_SIZE);
+    DEBUG_EVAC_PERM_IND;
+    COPY_FIXED_HDR;
+    COPY_WORD(IND_HS);
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(MIN_UPD_SIZE);
+    return(evac);
+}
+#endif
+
+/*** SELECTORS CODE (much like an indirection) ***/
+
+/* Evacuate a thunk which is selector; it has one free variable which
+   points to something which will evaluate to a constructor in a
+   single-constructor data type.
+ 
+   If it is so evaluated at GC time, we want to simply select the n'th
+   field.
+
+   This thunk is of course always a Spec thing, since it has only one
+   free var.
+
+   The constructor is guaranteed to be a Spec thing, so we know where
+   the n'th field is.
+
+   ToDo: what if the constructor is a Gen thing?
+*/
+static P_
+_EvacuateSelector_n(evac, n)
+  P_ evac;
+  I_ n;
+{
+    P_ maybe_con = (P_) evac[_FHS];
+
+    /* must be a SPEC 2 1 closure */
+    ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */
+
+#if defined(_GC_DEBUG)
+    if (SM_trace & 2)
+        fprintf(stderr, "Evac Selector: 0x%lx, info 0x%lx, maybe_con 0x%lx, info 0x%lx, tag %ld\n",
+		evac, INFO_PTR(evac), maybe_con,
+		INFO_PTR(maybe_con), INFO_TAG(INFO_PTR(maybe_con)));
+#endif
+
+    if (INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
+	  /* Evacuate as normal (it is size *2* because of MIN_UPD_SIZE) */
+	  return( _Evacuate_2(evac) );
+
+#if defined(_GC_DEBUG)
+    if (SM_trace & 2)
+        fprintf(stderr, "Evac Selector:shorting: 0x%lx -> 0x%lx\n",
+		evac, maybe_con[_FHS + n]);
+#endif
+
+    /* Ha!  Short it out */
+    evac = (P_) (maybe_con[_FHS + n]);	/* evac now has the result of the selection */
+
+#if defined(GCgn) || defined(GCap)
+    if (evac > OldGen)  /* Only evacuate new gen with generational collector */
+	evac = EVACUATE_CLOSURE(evac);
+#else
+    evac = EVACUATE_CLOSURE(evac);
+#endif
+
+    return(evac);
+}
+
+#define DEF_SEL_EVAC(n) \
+P_ CAT2(_EvacuateSelector_,n) (evac) P_ evac; \
+{ return(_EvacuateSelector_n(evac,n)); }
+
+/* all the entry points */
+DEF_SEL_EVAC(0)
+DEF_SEL_EVAC(1)
+DEF_SEL_EVAC(2)
+DEF_SEL_EVAC(3)
+DEF_SEL_EVAC(4)
+DEF_SEL_EVAC(5)
+DEF_SEL_EVAC(6)
+DEF_SEL_EVAC(7)
+DEF_SEL_EVAC(8)
+DEF_SEL_EVAC(9)
+DEF_SEL_EVAC(10)
+DEF_SEL_EVAC(11)
+DEF_SEL_EVAC(12)
+
+#ifdef CONCURRENT
+EVAC_FN(BQ)
+{
+    START_ALLOC(MIN_UPD_SIZE);
+    DEBUG_EVAC_BQ;
+
+    COPY_FIXED_HDR;
+    COPY_WORD(BQ_HS);
+
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(MIN_UPD_SIZE);
+
+    /* Add to OldMutables list (if evacuated to old generation) */
+    PROMOTE_MUTABLE(evac);
+
+    return(evac);
+}
+
+EVAC_FN(TSO)
+{
+    I_ count;
+
+    START_ALLOC(TSO_VHS + TSO_CTS_SIZE);
+    DEBUG_EVAC_TSO(TSO_VHS + TSO_CTS_SIZE);
+
+    COPY_FIXED_HDR;
+    for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) {
+    	COPY_WORD(count);
+    }
+
+    *TSO_INTERNAL_PTR(ToHp) = *TSO_INTERNAL_PTR(evac);
+
+    SET_FORWARD_REF(evac, ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(TSO_VHS + TSO_CTS_SIZE);
+
+    /* Add to OldMutables list (if evacuated to old generation) */
+    PROMOTE_MUTABLE(evac);
+
+    return evac;
+}
+
+EVAC_FN(StkO)
+{
+    I_ count;
+    I_ size  = STKO_CLOSURE_SIZE(evac);
+    I_ spa_offset = STKO_SpA_OFFSET(evac);
+    I_ spb_offset = STKO_SpB_OFFSET(evac);
+    I_ sub_offset = STKO_SuB_OFFSET(evac);
+    I_ offset;
+
+    START_ALLOC(size);
+    DEBUG_EVAC_STKO(STKO_CLOSURE_CTS_SIZE(evac) - spa_offset + 1, spb_offset);
+
+    COPY_FIXED_HDR;
+#ifdef DO_REDN_COUNTING
+    COPY_WORD(STKO_ADEP_LOCN);
+    COPY_WORD(STKO_BDEP_LOCN);
+#endif
+    COPY_WORD(STKO_SIZE_LOCN);
+    COPY_WORD(STKO_RETURN_LOCN);
+    COPY_WORD(STKO_LINK_LOCN);
+
+    /* Adjust the four stack pointers -- ORDER IS IMPORTANT!! */
+    offset = ToHp - evac;
+
+    STKO_SuB(ToHp) = STKO_SuB(evac) + offset;
+    STKO_SpB(ToHp) = STKO_SpB(evac) + offset;
+    STKO_SpA(ToHp) = STKO_SpA(evac) + offset;
+    STKO_SuA(ToHp) = STKO_SuA(evac) + offset;
+
+
+    /* Slide the A stack */
+    for (count = spa_offset; count <= STKO_CLOSURE_CTS_SIZE(evac); count++) {
+	COPY_WORD((STKO_HS-1) + count);
+    }
+
+    /* Slide the B stack, repairing internal pointers */
+    for (count = spb_offset; count >= 1;) {
+    	if (count > sub_offset) {
+	    COPY_WORD((STKO_HS-1) + count);
+    	    count--;
+    	} else {
+    	    P_ subptr;
+    	    /* Repair the internal pointers in the update frame */
+	    COPY_WORD((STKO_HS-1) + count + BREL(UF_RET));
+	    COPY_WORD((STKO_HS-1) + count + BREL(UF_UPDATEE));
+	    ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUA),offset);
+	    ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUB),offset);
+    	    subptr = GRAB_SuB(STKO_CLOSURE_ADDR(ToHp,sub_offset));
+    	    sub_offset = STKO_CLOSURE_OFFSET(ToHp,subptr);
+    	    count -= STD_UF_SIZE;
+    	}
+    }
+
+    SET_FORWARD_REF(evac, ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(size);
+
+    /* Add to OldMutables list (if evacuated to old generation) */
+    PROMOTE_MUTABLE(evac);
+
+    return evac;
+}
+
+#ifdef PAR
+EVAC_FN(FetchMe)
+{
+    START_ALLOC(2);
+    DEBUG_EVAC(2);
+    COPY_FIXED_HDR;
+    COPY_WORD(FETCHME_GA_LOCN);
+    ASSERT(GALAlookup(FETCHME_GA(evac)) != NULL);
+
+    SET_FORWARD_REF(evac,ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(2);
+
+    /* Add to OldMutables list (if evacuated to old generation) */
+    PROMOTE_MUTABLE(evac);
+
+    return(evac);
+}
+
+EVAC_FN(BF)
+{
+    I_ count;
+
+    START_ALLOC(BF_CLOSURE_SIZE(evac));
+    DEBUG_EVAC_BF;
+
+    COPY_FIXED_HDR;
+    for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) {
+    	COPY_WORD(count);
+    }
+    COPY_WORD(BF_LINK_LOCN);
+    COPY_WORD(BF_NODE_LOCN);
+    COPY_WORD(BF_GTID_LOCN);
+    COPY_WORD(BF_SLOT_LOCN);
+    COPY_WORD(BF_WEIGHT_LOCN);
+
+    SET_FORWARD_REF(evac, ToHp);
+    evac = ToHp;
+    FINISH_ALLOC(BF_CLOSURE_SIZE(evac));
+
+    /* Add to OldMutables list (if evacuated to old generation) */
+    PROMOTE_MUTABLE(evac);
+
+    return evac;
+}
+#endif  /* PAR */
+#endif	/* CONCURRENT */
+
+/*** SPECIAL CAF CODE ***/
+
+/* Evacuation: Return closure pointed to (already explicitly evacuated) */
+/* Scavenging: Should not be scavenged */  
+
+P_
+_Evacuate_Caf(evac)
+P_ evac;
+{
+    DEBUG_EVAC_CAF_RET;
+    evac = (P_) IND_CLOSURE_PTR(evac);
+    return(evac);
+}
+
+/* In addition we need an internal Caf indirection which evacuates,
+   updates and returns the indirection. Before GC is started the
+   @CAFlist@ must be traversed and the info tables set to this.
+*/
+
+P_
+_Evacuate_Caf_Evac_Upd(evac)
+  P_ evac;
+{
+    P_ closure = evac;
+
+    DEBUG_EVAC_CAF_EVAC1;
+    INFO_PTR(evac) = (W_) Caf_info;		/* Change to return CAF */
+
+    evac = (P_) IND_CLOSURE_PTR(evac);          /* Grab reference and evacuate */
+
+#if defined(GCgn) || defined(GCap)
+    if (evac > OldGen)  /* Only evacuate new gen with generational collector */
+	evac = EVACUATE_CLOSURE(evac);
+#else
+    evac = EVACUATE_CLOSURE(evac);
+#endif
+
+    IND_CLOSURE_PTR(closure) = (W_) evac;       /* Update reference */
+
+    DEBUG_EVAC_CAF_EVAC2;
+    return(evac);
+
+    /* This will generate a stack of returns for a chain of indirections!
+       However chains can only be 2 long.
+   */
+}
+
+
+/*** CONST CLOSURE CODE ***/
+
+/* Evacuation: Just return address of the static closure stored in the info table */
+/* Scavenging: Const closures should never be scavenged */
+
+P_
+_Evacuate_Const(evac)
+P_ evac;
+{
+    DEBUG_EVAC_CONST;
+    evac = CONST_STATIC_CLOSURE(INFO_PTR(evac));
+    return(evac);
+}
+
+void
+_Scavenge_Const(STG_NO_ARGS)
+{
+    fprintf(stderr,"Called _Scavenge_Const: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
+    abort();
+}
+
+
+/*** CHARLIKE CLOSURE CODE ***/
+
+/* Evacuation: Just return address of the static closure stored fixed array */
+/* Scavenging: CharLike closures should never be scavenged */
+
+P_
+_Evacuate_CharLike(evac)
+P_ evac;
+{
+    DEBUG_EVAC_CHARLIKE;
+    evac = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac));
+    return(evac);
+}
+
+void
+_Scavenge_CharLike(STG_NO_ARGS)
+{
+    fprintf(stderr,"Called _Scavenge_CharLike: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
+    abort();
+}
+\end{code}
+
+--- INTLIKE CLOSURE CODE ---
+
+Evacuation: Return address of the static closure if available
+Otherwise evacuate converting to aux closure.
+
+Scavenging: IntLike closures should never be scavenged.
+
+There are some tricks here:
+\begin{enumerate}
+\item
+The main trick is that if the integer is in a certain range, we
+replace it by a pointer to a statically allocated integer.
+\end{enumerate}
+
+(Would it not be more efficient to update the copy directly since
+we're about to set a forwarding reference in the original? ADR)
+
+\begin{code}
+EVAC_FN(IntLike)
+{
+    I_ val = INTLIKE_VALUE(evac);
+ 
+    if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {   /* in range of static closures */
+	DEBUG_EVAC_INTLIKE_TO_STATIC;
+	evac = (P_) INTLIKE_CLOSURE(val);             /* return appropriate static closure */
+    }
+    else {
+	START_ALLOC(1);                                   /* evacuate closure of size 1 */
+	DEBUG_EVAC(1);
+	COPY_FIXED_HDR;
+	SPEC_COPY_FREE_VAR(1);
+	SET_FORWARD_REF(evac,ToHp);
+	evac = ToHp;
+	FINISH_ALLOC(1);
+    }
+    return(evac);
+}
+
+#if defined (GCgn)
+GEN_EVAC_CODE(1)
+GEN_EVAC_CODE(2)
+GEN_EVAC_CODE(3)
+GEN_EVAC_CODE(4)
+GEN_EVAC_CODE(5)
+GEN_EVAC_CODE(6)
+GEN_EVAC_CODE(7)
+GEN_EVAC_CODE(8)
+GEN_EVAC_CODE(9)
+GEN_EVAC_CODE(10)
+GEN_EVAC_CODE(11)
+GEN_EVAC_CODE(12)
+GEN_EVAC_CODE(S)
+GEN_EVAC_CODE(Dyn)
+GEN_EVAC_CODE(Tuple)
+GEN_EVAC_CODE(Data)
+GEN_EVAC_CODE(MuTuple)
+GEN_EVAC_CODE(IntLike)	/* ToDo: may create oldgen roots referencing static ints */
+GEN_EVAC_CODE(CAT2(BH_,MIN_UPD_SIZE))
+GEN_EVAC_CODE(CAT2(BH_,MIN_NONUPD_SIZE))
+#endif /* GCgn */
+
+#else  /* ! _INFO_COPYING */
+This really really should not ever ever come up!
+#endif /* ! _INFO_COPYING */
+\end{code}
diff --git a/ghc/runtime/storage/SMextn.lc b/ghc/runtime/storage/SMextn.lc
new file mode 100644
index 0000000000..bd39ae4169
--- /dev/null
+++ b/ghc/runtime/storage/SMextn.lc
@@ -0,0 +1,367 @@
+\section[SM-extensions]{Storage Manager Extensions}
+
+ToDo ADR: Maybe this should be split between SMcopying.lc and
+SMcompacting.lc?
+
+
+This is a collection of C functions use in implementing the stable
+pointer and malloc pointer extensions. 
+
+The motivation for making this a separate file/section is twofold:
+
+1) It let's us focus on one thing.
+
+2) If we don't do this, there will be a huge amount of repetition
+   between the various GC schemes --- a maintenance nightmare.
+
+The second is the major motivation.  
+
+There are three main parts to this file:
+
+1) Code which is common to all GC schemes.
+
+2) Code for use in a compacting collector used in the 1-space, dual
+   mode and for collecting old generations in generational collectors.
+
+3) Code for use in a copying collector used in the 2-space, dual mode
+   and for collecting young generations in generational collectors.
+
+When debugging, it is incredibly helpful to trash part of the heap
+(say) once you're done with it.
+
+Remembering that @sm->hp@ points to the next word to be allocated, a
+typical use is
+
+\begin{pseudocode}
+#ifdef DEBUG
+  TrashMem(sm->hp+1, sm->hplim);
+#endif
+\end{pseudocode}
+
+\begin{code} 
+
+#if defined(GC1s)
+
+#define  SCAN_REG_DUMP
+#include "SMinternal.h"
+REGDUMP(ScanRegDump);
+
+#else /* GC2s, GCdu, GCap, GCgn */
+
+#define SCAV_REG_MAP
+#include "SMinternal.h"
+REGDUMP(ScavRegDump);
+
+#endif
+#include "SMextn.h"
+
+#ifdef DEBUG
+
+void
+TrashMem(from, to)
+  P_ from, to;
+{
+/* assertion overly strong - if free_mem == 0, sm->hp == sm->hplim */
+/*  ASSERT( from <= to ); */
+    if (SM_trace)
+	printf("Trashing from 0x%lx to 0x%lx inclusive\n", (W_) from, (W_) to);
+    while (from <= to) {
+	*from++ = DEALLOCATED_TRASH;
+    }
+}
+
+#endif /* DEBUG */
+\end{code}
+
+\begin{code}
+
+#ifndef PAR  	/* To end of the file */
+
+\end{code}
+
+\downsection
+\section[SM-extensions-common-code]{Code common to all GC schemes}
+
+\begin{code}
+EXTDATA(EmptySPTable_closure);
+
+void initExtensions( sm )
+  smInfo *sm;
+{
+  sm->MallocPtrList = NULL;
+#if defined(GCap) || defined(GCgn)
+  sm->OldMallocPtrList = NULL;
+#endif
+
+  sm->StablePointerTable = (P_) EmptySPTable_closure;
+}
+
+extern void FreeMallocPtr PROTO(( StgMallocPtr mp ));
+\end{code}
+
+\begin{code}
+#if defined(DEBUG)
+\end{code}
+
+When a Malloc Pointer is released, there should be absolutely no
+references to it.  To encourage and dangling references to show
+themselves, we'll trash its contents when we're done with it.
+
+\begin{code}
+#define TRASH_MallocPtr_CLOSURE( mptr ) Trash_MallocPtr_Closure(mptr)
+
+void
+Trash_MallocPtr_Closure(mptr)
+  P_ mptr;
+{ int i;
+  for( i = 0; i != MallocPtr_SIZE + _FHS; i++ ) {
+    mptr[ i ] = DEALLOCATED_TRASH;
+  }
+}
+\end{code}
+
+Also, every time we fiddle with the MallocPtr list, we should check it
+still makes sense.  This function returns @0@ if the list is sensible.
+
+(Would maintaining a separate Malloc Ptr count allow better testing?)
+
+\begin{code}
+void
+Validate_MallocPtrList( MallocPtrList )
+  P_ MallocPtrList;
+{
+  P_ MPptr;
+
+  for(MPptr = MallocPtrList; 
+      MPptr != NULL;
+      MPptr = MallocPtr_CLOSURE_LINK(MPptr) ) {
+    CHECK_MallocPtr_CLOSURE(MPptr);
+  }
+}
+\end{code}
+
+\begin{code}
+#else /* !DEBUG */
+
+#define TRASH_MallocPtr_CLOSURE( mp ) /* nothing */
+
+#endif /* !DEBUG */  
+\end{code}
+
+\begin{code}
+#ifdef DEBUG
+
+#define TRACE_MallocPtr(MPptr) Trace_MallocPtr( MPptr )
+#define TRACE_MPdies(MPptr) Trace_MPdies()
+#define TRACE_MPlives(MPptr) Trace_MPlives()
+#define TRACE_MPforwarded(MPptr, newAddress) Trace_MPforwarded( MPptr, newAddress )
+
+void
+Trace_MallocPtr( MPptr )
+  P_ MPptr;
+{
+  if (SM_trace & 16) {
+    printf("DEBUG: MallocPtr(%lx)=<%lx,_,%lx,%lx,%lx>\n", (W_) MPptr, (W_) MPptr[0], (W_) MPptr[1], (W_) MPptr[2], (W_) MPptr[3]);
+    printf(" Data = %lx, Next = %lx\n", 
+	(W_) MallocPtr_CLOSURE_DATA(MPptr), (W_) MallocPtr_CLOSURE_LINK(MPptr) );
+  }
+}
+
+void
+Trace_MPdies()
+{
+  if (SM_trace & 16) {
+    printf(" dying\n");
+  }
+}
+
+void
+Trace_MPlives()
+{
+  if (SM_trace & 16) { 
+    printf(" lived to tell the tale \n"); 
+  }
+}
+
+void
+Trace_MPforwarded( MPPtr, newAddress )
+  P_ MPPtr, newAddress;
+{
+  if (SM_trace & 16) {
+    printf(" forwarded to %lx\n", (W_) newAddress);
+  }
+}
+
+#else
+
+#define TRACE_MallocPtr(MPptr) /* nothing */
+#define TRACE_MPdies(MPptr) /* nothing */
+#define TRACE_MPlives(MPptr) /* nothing */
+#define TRACE_MPforwarded(MPptr, newAddress) /* nothing */
+
+#endif /* DEBUG */
+\end{code}
+
+
+\section[SM-extensions-compacting-code]{Compacting Collector Code}
+
+
+\begin{code}
+#if defined(_INFO_COMPACTING)
+
+/* Sweep up the dead MallocPtrs */
+
+/* Note that this has to happen before the linking phase trashes
+   the stable pointer table so that the FreeMallocPtr function can
+   safely call freeStablePointer. 
+*/
+
+void
+sweepUpDeadMallocPtrs( MallocPtrList, base, bits )
+  P_ MallocPtrList;
+  P_ base;
+  BitWord *bits;
+{
+    P_ MPptr, temp;
+    I_ MallocPtr_deaths = 0;
+    long _hp_word, bit_index, bit;
+
+    /* At this point, the MallocPtrList is in an invalid state (since
+       some info ptrs will have been mangled) so we can't validate
+       it. ADR */
+
+    DEBUG_STRING("Reporting Dead Malloc Ptrs:");
+    MPptr = MallocPtrList;
+    while ( MPptr != NULL ) {
+
+      TRACE_MallocPtr(MPptr);
+
+      _hp_word = MPptr - base;
+      bit_index = _hp_word / BITS_IN(BitWord);
+      bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1));
+      if ( !( bits[bit_index] & bit ) ) { /* dead */
+
+	TRACE_MPdies( MPptr );
+	FreeMallocPtr( MallocPtr_CLOSURE_DATA(MPptr) );
+	MallocPtr_deaths++;
+
+	temp = MPptr;
+	MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+	/* Now trash the closure to encourage bugs to show themselves */
+	TRASH_MallocPtr_CLOSURE( temp );
+
+      } else { 
+
+	TRACE_MPlives(MPptr);
+	MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+      }
+    }
+}
+
+#endif /* _INFO_COMPACTING */
+\end{code}
+
+\section[SM-extensions-copying-code]{Copying Collector Code}
+
+\begin{code}
+#if defined(_INFO_COPYING)
+
+/* ToDo: a possible optimisation would be to maintain a flag that
+   told us whether the SPTable had been updated (with new
+   pointers) and so needs to be GC'd.  A simple way of doing this
+   might be to generalise the MUTUPLE closures to MUGEN closures.
+*/
+void evacSPTable( sm )
+smInfo *sm;
+{
+  DEBUG_STRING("Evacuate Stable Pointer Table:");
+  {
+    P_ evac = sm->StablePointerTable;
+    sm->StablePointerTable = EVACUATE_CLOSURE(evac);
+  }
+}
+
+
+
+/* First attempt at Malloc Ptr hackery... Later versions might 
+   do something useful with the two counters. [ADR]      */
+
+#if defined(DEBUG)
+#if defined(GCgn)
+
+EXTDATA_RO(Forward_Ref_New_info);
+EXTDATA_RO(Forward_Ref_Old_info);
+EXTDATA_RO(OldRoot_Forward_Ref_info);
+
+#else
+
+EXTDATA_RO(Forward_Ref_info);
+
+#endif
+#endif
+
+/* 
+  Call FreeMallocPtr on any dead MPs in oldMPList, add the remainder
+  to new sticking the result into newMPList.
+*/
+void
+reportDeadMallocPtrs(oldMPList, new, newMPList)
+  P_ oldMPList;
+  P_ new;
+  P_ *newMPList;
+{
+    P_ MPptr, temp;
+    I_ MP_no = 0, MP_deaths = 0;
+
+    /* At this point, the MallocPtrList is in an invalid state (since
+       some info ptrs will have been mangled) so we can't validate
+       it. ADR */
+
+    DEBUG_STRING("Updating MallocPtr List and reporting casualties:");
+    MPptr = oldMPList;
+    while ( MPptr != NULL ) {
+      TRACE_MallocPtr(MPptr);
+
+      if ((P_) INFO_PTR(MPptr) == MallocPtr_info ) {
+	/* can't have been forwarded - must be dead */
+
+	TRACE_MPdies(MPptr);
+	FreeMallocPtr( MallocPtr_CLOSURE_DATA(MPptr) );
+	MP_deaths++;
+
+	temp = MPptr;
+	MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+
+	/* Now trash the closure to encourage bugs to show themselves */
+	TRASH_MallocPtr_CLOSURE( temp );
+      } else { /* Must have been forwarded - so it must be live */
+
+	P_ newAddress = (P_) FORWARD_ADDRESS(MPptr);
+
+#if defined(GCgn)
+	ASSERT( ( (P_) INFO_PTR(MPptr) == Forward_Ref_New_info ) ||
+		( (P_) INFO_PTR(MPptr) == Forward_Ref_Old_info ) ||
+		( (P_) INFO_PTR(MPptr) == OldRoot_Forward_Ref_info ) );
+#else
+	ASSERT( (P_) INFO_PTR(MPptr) == Forward_Ref_info );
+#endif
+
+	TRACE_MPforwarded( MPptr, newAddress );
+	MallocPtr_CLOSURE_LINK(newAddress) = new;
+	new = newAddress;
+	MP_no++;
+	MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+      }
+    }
+
+    VALIDATE_MallocPtrList( new );
+    *newMPList = new;
+}
+#endif /* _INFO_COPYING */
+\end{code}
+
+\upsection
+
+\begin{code}
+#endif /* !PAR */
+\end{code}
diff --git a/ghc/runtime/storage/SMextn.lh b/ghc/runtime/storage/SMextn.lh
new file mode 100644
index 0000000000..ed2e3a86e6
--- /dev/null
+++ b/ghc/runtime/storage/SMextn.lh
@@ -0,0 +1,40 @@
+\section[SMextensions-header]{Header file for SMextensions}
+
+\begin{code}
+#ifndef PAR
+
+extern void initExtensions PROTO((smInfo *sm));
+
+#if defined(_INFO_COPYING)
+
+extern void evacSPTable PROTO((smInfo *sm));
+extern void reportDeadMallocPtrs PROTO((StgPtr oldMPList, StgPtr new, StgPtr *newMPLust));
+
+#endif /* _INFO_COPYING */
+
+#if defined(_INFO_COMPACTING)
+
+extern void sweepUpDeadMallocPtrs PROTO((
+					 P_ MallocPtrList,
+					 P_ base,
+					 BitWord *bits
+					 ));
+
+#endif /* _INFO_COMPACTING */
+
+extern void TrashMem PROTO(( P_ from, P_ to ));
+
+#if defined(DEBUG)
+
+extern void Trash_MallocPtr_Closure PROTO((P_ mptr));
+extern void Validate_MallocPtrList PROTO(( P_ MallocPtrList ));
+
+extern void Trace_MPdies  PROTO((void));
+extern void Trace_MPlives PROTO((void));
+extern void Trace_MPforwarded PROTO(( P_ MPPtr, P_ newAddress ));
+
+
+#endif /* DEBUG */
+
+#endif /* !PAR */
+\end{code}
diff --git a/ghc/runtime/storage/SMgen.lc b/ghc/runtime/storage/SMgen.lc
new file mode 100644
index 0000000000..302ee640f4
--- /dev/null
+++ b/ghc/runtime/storage/SMgen.lc
@@ -0,0 +1,832 @@
+***************************************************************************
+
+                      GENERATIONAL GARBAGE COLLECTION
+
+Global heap requirements as for 1s and 2s collectors.
+    ++ All closures in the old generation that are updated must be
+       updated with indirections and placed on the linked list of
+       updated old generation closures.
+
+
+Promotion collection:
+---------------------
+
+Collects allocation area into 2nd semi-space and promotes new semi-space
+by collecting into old generation.
+
+evac < AllocGen ==> Collect to old generation (see _EvacuateP)
+
+Roots: Roots, Astk, Bstk, OldRoots, OldInNew, CAFlist, NewCAFlist
+
+OldRoots: Newly promoted closures may reference new semi-space.
+
+          Discard OldInNew roots (promoted).
+            This keeps recent new gen roots in new gen.
+          Remember OldRoots in alloc (not promoted).
+
+          When evacuating to new check if Scav in OldGen, if so 
+            allocate oldgen root ind and add to OldInNew.
+            N.B. This includes evacuating a forward reference.
+          Set special forward ref to this OldGen root closure.
+            if oldgen evacs return oldgen root else return new gen.
+
+CAFlist:  Remember NewCAFlist in OldCAFlist (promoted).
+          Remember CAFlist in NewCAFlist (not promoted).
+
+***************************************************************************
+
+\begin{code}
+#if defined(GCgn)
+
+#define SCAV_REG_MAP
+#include "SMinternal.h"
+
+REGDUMP(ScavRegDump);
+
+genData genInfo = {0, 0, 0, 0,
+		   0, 0,                 /* Alloc */
+		   0, {{0, 0}, {0, 0}},  /* New Gen */
+		   0, 0, 0, 0, 0, 0,     /* Old Gen */
+		   0, 0, 0, 0, 0, 0, 0,  /* OldRoots & CAfs */
+		   0, {{0, 0}, {0, 0}}   /* 2s */
+		  };
+
+P_ heap_space = 0;		/* Address of first word of slab 
+				   of memory allocated for heap */
+
+P_ hp_start;	        /* Value of Hp when reduction was resumed */
+                                /* Always allocbase - 1 */
+
+I_
+initHeap( sm )
+    smInfo *sm;    
+{
+    I_ heap_error = 0;
+    I_ bit_words;
+
+    /* should cause link error */
+    ADRpanic("Completely untested on SP and MP stuff... also doesn't benefit from commoning up in SMcopying and SMcompacting");
+
+    if (heap_space == 0) { /* allocates if it doesn't already exist */
+
+	/* Allocate the roots space */
+	sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+
+	/* Allocate the heap */
+	heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+
+	if (SM_force_gc == USE_2s) {
+	    stat_init("TWOSPACE(GEN)",
+		      " No of Roots  Caf   Caf    Astk   Bstk",
+		      "Astk Bstk Reg  No  bytes  bytes  bytes");
+	} else {
+	    stat_init("GEN",
+		      "Promote Old    No of Roots  Caf Mut-  Old Old OldGen  Collec  Resid",
+		      " bytes roots  Astk Bstk Reg  No able  Alc New  bytes   tion   %heap");
+	}
+    }
+
+    if (SM_force_gc == USE_2s) {
+	genInfo.semi_space = SM_word_heap_size / 2;
+	genInfo.space[0].base = HEAP_FRAME_BASE(heap_space, genInfo.semi_space);
+	genInfo.space[1].base = HEAP_FRAME_BASE(heap_space + genInfo.semi_space, genInfo.semi_space);
+	genInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, genInfo.semi_space);
+	genInfo.space[1].lim = HEAP_FRAME_LIMIT(heap_space + genInfo.semi_space, genInfo.semi_space);
+	genInfo.semi_space = 0;
+	genInfo.oldlim = heap_space - 1;  /* Never in old generation */
+
+	sm->hp = hp_start = genInfo.space[genInfo.semi_space].base - 1;
+
+	if (SM_alloc_size) {
+	    sm->hplim = sm->hp + SM_alloc_size;
+	    SM_alloc_min = 0; /* No min; alloc size specified */
+
+	    if (sm->hplim > genInfo.space[genInfo.semi_space].lim) {
+		fprintf(stderr, "Not enough heap for requested alloc size\n");
+		return -1;
+	    }
+	} else {
+	    sm->hplim = genInfo.space[genInfo.semi_space].lim;
+	}
+
+	sm->OldLim = genInfo.oldlim;
+	sm->CAFlist = NULL;
+
+#ifndef PAR
+	initExtensions( sm );
+#endif
+
+	if (SM_trace) {
+	    fprintf(stderr, "GEN(2s) Heap: 0x%lx .. 0x%lx\n",
+		    (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size));
+	    fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n         hp 0x%lx, hplim 0x%lx, free %ld\n",
+		    genInfo.semi_space,
+		    (W_) genInfo.space[genInfo.semi_space].base,
+		    (W_) genInfo.space[genInfo.semi_space].lim,
+		    (W_) sm->hp, (W_) sm->hplim, (I_) (sm->hplim - sm->hp));
+	}
+	return 0;
+    }
+
+    if (SM_alloc_size == 0) SM_alloc_size = DEFAULT_ALLOC_SIZE;
+
+    genInfo.alloc_words = SM_alloc_size;
+    genInfo.new_words   = SM_alloc_size;
+
+    genInfo.allocbase  = heap_space + SM_word_heap_size - genInfo.alloc_words;
+    genInfo.alloclim   = heap_space + SM_word_heap_size - 1;
+
+    genInfo.newgen[0].newbase   = genInfo.allocbase - genInfo.new_words;
+    genInfo.newgen[0].newlim    = genInfo.newgen[0].newbase - 1;
+
+    genInfo.newgen[1].newbase   = genInfo.allocbase - 2 * genInfo.new_words;
+    genInfo.newgen[1].newlim    = genInfo.newgen[1].newbase - 1;
+
+    genInfo.oldbase = heap_space;
+
+    if (SM_major_gen_size) {
+	genInfo.old_words = SM_major_gen_size;
+	genInfo.oldend    = heap_space + genInfo.old_words - 1;
+	genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
+	                                 /* ToDo: extra old ind words not accounted for ! */
+
+	bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+	if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
+	    /* bit vector in allocation area */
+	    genInfo.bit_vect  = (BitWord *) genInfo.allocbase;
+	    if (genInfo.oldend >= genInfo.newgen[1].newbase) heap_error = 1;
+	} else {
+	    /* bit area in free area */
+	    genInfo.bit_vect   = (BitWord *) genInfo.oldend + 1;
+	    if (genInfo.bit_vect + bit_words >= (BitWord *) genInfo.newgen[1].newbase) heap_error = 1;
+	}
+    } else {
+	genInfo.old_words = SM_word_heap_size - genInfo.alloc_words - 2 * genInfo.new_words;
+	genInfo.oldend    = heap_space + genInfo.old_words - 1;
+	genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
+	                                 /* ToDo: extra old ind words not accounted for ! */
+
+	bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+	if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
+	    /* bit vector in allocation area */
+	    genInfo.bit_vect  = (BitWord *) genInfo.allocbase;
+	} else {
+	    /* bit vector in reserved space in old generation */
+	    bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+
+	    genInfo.bit_vect   = (BitWord *) heap_space;
+	    genInfo.oldbase   += bit_words;
+	    genInfo.old_words -= bit_words;
+	}
+	if (genInfo.oldbase > genInfo.oldthresh) heap_error = 1;
+    }
+
+    if (heap_error) {
+	fprintf(stderr, "initHeap: Requested heap size: %ld\n", SM_word_heap_size);
+	fprintf(stderr, "          Alloc area %ld  Delay area %ld  Old area %ld  Bit area %ld\n",
+		                   genInfo.alloc_words, genInfo.new_words * 2, genInfo.old_words,
+		                   genInfo.bit_vect == (BitWord *) genInfo.allocbase ? 0 : bit_words);
+        fprintf(stderr, "          Heap not large enough for generational gc with these specs\n");
+	fprintf(stderr, "          +RTS -H<size> option will increase heap size and/or\n");
+	fprintf(stderr, "               -A<size> option will decrease allocation area\n");
+	return -1;
+    }
+
+
+    genInfo.oldlim     = genInfo.oldbase - 1;
+    genInfo.oldwas     = genInfo.oldbase - 1;
+
+    genInfo.curnew     = 0;
+    genInfo.OldInNew   = 0;
+    genInfo.OldInNewno = 0;
+    genInfo.NewCAFlist = NULL;
+    genInfo.NewCAFno   = 0;
+    genInfo.OldCAFlist = NULL;
+    genInfo.OldCAFno   = 0;
+
+    genInfo.PromMutables = 0;
+
+    sm->hp = hp_start = genInfo.allocbase - 1;
+    sm->hplim = genInfo.alloclim;
+
+    sm->OldLim = genInfo.oldlim;
+    sm->CAFlist = NULL;
+
+#ifndef PAR
+    initExtensions( sm );
+#endif
+
+    if (SM_trace) {
+	fprintf(stderr, "GEN Heap: 0x%lx .. 0x%lx\n",
+		(W_) heap_space, (W_) (heap_space + SM_word_heap_size - 1));
+	fprintf(stderr, "          alloc %ld, new %ld, old %ld, bit %ld\n",
+		genInfo.alloc_words, genInfo.new_words, genInfo.old_words, bit_words);
+	fprintf(stderr, "          allocbase 0x%lx, alloclim 0x%lx\n",
+		(W_) genInfo.allocbase, (W_) genInfo.alloclim);
+	fprintf(stderr, "          newbases 0x%lx 0x%lx\n",
+		(W_) genInfo.newgen[0].newbase, (W_) genInfo.newgen[1].newbase);
+	fprintf(stderr, "          oldbase 0x%lx oldthresh 0x%lx bits 0x%lx\n",
+		(W_) genInfo.oldbase, (W_) genInfo.oldthresh, (W_) genInfo.bit_vect);
+	fprintf(stderr, "          hp 0x%lx, hplim 0x%lx\n",
+		(W_) sm->hp, (W_) sm->hplim);
+    }
+
+    return 0;
+}
+
+I_
+collect2s(reqsize, sm)
+    W_ reqsize;
+    smInfo *sm;
+{
+    I_	root, bstk_roots, caf_roots, extra_caf_words;
+    PP_	stackptr;
+    P_	CAFptr, updateFramePtr, caf_start;
+
+    I_ free_space,	/* No of words of free space following GC */
+        alloc, 		/* Number of words allocated since last GC */
+	resident;	/* Number of words remaining after GC */
+
+    SAVE_REGS(&ScavRegDump); /* Save registers */
+
+    if (SM_trace)
+	fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, req %lu\n",
+		genInfo.semi_space,
+		(W_) genInfo.space[genInfo.semi_space].base,
+		(W_) genInfo.space[genInfo.semi_space].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
+
+    alloc = sm->hp - hp_start;
+    stat_startGC(alloc);
+
+    genInfo.semi_space = NEXT_SEMI_SPACE(genInfo.semi_space);
+    ToHp = genInfo.space[genInfo.semi_space].base - 1;
+    Scav = genInfo.space[genInfo.semi_space].base;
+    OldGen = sm->OldLim; /* always evac ! */
+    
+    DEBUG_STRING("Setting Evac & Upd CAFs:");
+    for (CAFptr = sm->CAFlist; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+	INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
+    }
+
+#ifdef PAR
+    EvacuateLocalGAs(rtsTrue);
+#else
+    evacSPTable( sm );
+#endif /* PAR */
+
+    DEBUG_STRING("Evacuate Roots:");
+    for (root = 0; root < sm->rootno; root++) {
+	P_ evac = sm->roots[root];
+	sm->roots[root] = EVACUATE_CLOSURE(evac);
+    }
+
+#if !defined(PAR)
+
+    DEBUG_STRING("Evacuate A Stack:");
+    for (stackptr = MAIN_SpA;
+	 SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
+		/* botA points to bottom-most word */
+	 stackptr = stackptr + AREL(1)) {
+	P_ evac = *stackptr;
+	*stackptr = EVACUATE_CLOSURE(evac);
+    }
+    DEBUG_STRING("Evacuate B Stack:");
+    bstk_roots = 0;
+    for (updateFramePtr = MAIN_SuB;   /* SuB points to topmost update frame */
+	 SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
+		/* botB points to bottom-most word */
+	 /* re-initialiser given explicitly */) {
+
+	P_ evac = GRAB_UPDATEE(updateFramePtr);
+	PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
+	bstk_roots++;
+
+	updateFramePtr = GRAB_SuB(updateFramePtr);
+    }
+#endif	/* PAR */
+
+    DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
+    while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+    DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
+
+    DEBUG_STRING("Evacuate & Scavenge CAFs:");
+    caf_roots = 0;
+    caf_start = ToHp;
+    for (CAFptr = sm->CAFlist; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+
+	EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
+	caf_roots++;
+
+	DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
+	while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+	DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
+
+	/* this_extra_caf_words = ToHp - this_caf_start; */
+	/* ToDo: Report individual CAF space */
+    }
+    extra_caf_words = ToHp - caf_start;
+
+#ifdef PAR
+    RebuildGAtables(rtsTrue);
+#else
+    reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+#endif /* PAR */
+
+    /* TIDY UP AND RETURN */
+
+    sm->hp = hp_start = ToHp;  /* Last allocated word */
+    sm->hplim = genInfo.space[genInfo.semi_space].lim;
+ 
+    resident = sm->hp - (genInfo.space[genInfo.semi_space].base - 1);
+    /* DONT_DO_MAX_RESIDENCY -- because this collector is utterly hosed */
+    free_space = sm->hplim - sm->hp;
+
+    if (SM_stats_verbose) {
+	char comment_str[BIG_STRING_LEN];
+#ifndef PAR
+	sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+		bstk_roots, sm->rootno,
+		caf_roots, extra_caf_words*sizeof(W_),
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
+		(SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
+#else
+	/* ToDo: come up with some interesting statistics for the parallel world */
+	sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
+		0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
+#endif
+	stat_endGC(alloc, SM_word_heap_size, resident, comment_str);
+    } else {
+	stat_endGC(alloc, SM_word_heap_size, resident, "");
+    }
+
+    if (SM_trace)
+	fprintf(stderr, "Done:  space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, free %lu\n",
+		genInfo.semi_space,
+		(W_) genInfo.space[genInfo.semi_space].base,
+		(W_) genInfo.space[genInfo.semi_space].lim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
+
+#ifdef DEBUG
+    /* To help flush out bugs, we trash the part of the heap from
+       which we're about to start allocating. */
+    TrashMem(sm->hp+1, sm->hplim);
+#endif /* DEBUG */
+
+    RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+
+    if ((SM_alloc_size > free_space) || (reqsize > free_space))
+	return(-1);	/* Heap exhausted */
+
+    return(0);          /* Heap OK */
+}
+
+
+I_
+collectHeap(reqsize, sm)
+    W_ reqsize;
+    smInfo *sm;
+{
+    PP_ stackptr, botA;
+    P_    mutptr, prevmut, updateFramePtr, botB,
+              CAFptr, prevCAF, oldroot, oldstartToHp, oldstartOldHp,
+              oldscav, newscav;
+    I_    root, rootno, bstk_roots, mutable, alloc_cafs, new_cafs,
+              alloc_oldroots, new_oldroots, old_words;
+
+    I_    bit_words;
+    P_    oldlim;
+    PP_ CAFlocs, CAFloc;
+
+       I_ alloc, 	/* number of words allocated since last GC */
+        collect,        /* number of words collected */
+        promote,	/* number of words promoted  */
+	resident,	/* number of words remaining */
+	total_resident;	/* total number of words remaining after major collection */
+
+    fflush(stdout);     /* Flush stdout at start of GC */
+
+    if (SM_force_gc == USE_2s) {
+	return collect2s(reqsize, sm);
+    }
+
+
+    if (reqsize > genInfo.alloc_words) {
+	fprintf(stderr, "collectHeap: Required size %ld greater then allocation area %ld!\n",
+		reqsize, genInfo.alloc_words);
+	fprintf(stderr, "             Rerun using  +RTS -A<size>  to increase allocation area\n");
+	EXIT(EXIT_FAILURE);
+    }
+
+    SAVE_REGS(&ScavRegDump);        /* Save registers */
+
+    if (SM_trace) fprintf(stderr, "GEN Start: hp 0x%lx, hplim 0x%lx, req %ld  Minor\n",
+			  (W_) sm->hp, (W_) sm->hplim, (I_) (reqsize * sizeof(W_)));
+
+    alloc = sm->hp - hp_start;
+    stat_startGC(alloc);
+
+    /* MINOR COLLECTION WITH PROMOTION */
+    
+    collect = alloc + (genInfo.newgen[genInfo.curnew].newlim - genInfo.newgen[genInfo.curnew].newbase + 1);
+    genInfo.curnew = (genInfo.curnew + 1) % 2;
+    
+    ToHp     = genInfo.newgen[genInfo.curnew].newbase - 1;
+    OldGen   = genInfo.oldend;     /* <= OldGen indicates in the old generation */
+    
+    AllocGen = genInfo.allocbase;  /* < AllocGen indicates in delay bucket -> promote */
+    OldHp    = genInfo.oldlim;
+    
+    newscav  = genInfo.newgen[genInfo.curnew].newbase; /* Point to (info field of) first closure */
+    oldscav  = genInfo.oldlim + 1;                     /* Point to (info field of) first closure */
+
+
+    DEBUG_STRING("Setting Evac & Upd CAFs:");
+    for (CAFptr = sm->CAFlist; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+	INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
+    }
+    for (CAFptr = genInfo.NewCAFlist; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+	INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
+    }
+    
+
+    /* FIRST: Evacuate and scavenge OldMutable, Roots, AStk & BStk */
+    /* Ensure these roots don't use old generation root indirection when evacuated */
+    Scav = newscav;
+    
+    DEBUG_STRING("Evacuate Roots:");
+    for (root = 0, rootno = sm->rootno; root < rootno; root++) {
+	P_ evac = sm->roots[root];
+	if (evac > OldGen) {
+	    sm->roots[root] = EVACUATE_CLOSURE(evac);
+	}
+    }
+
+#if !defined(PAR)    
+    DEBUG_STRING("Evacuate A Stack:");
+    for (stackptr = MAIN_SpA, botA = stackInfo.botA;
+	 SUBTRACT_A_STK(stackptr, botA) >= 0;
+	 stackptr = stackptr + AREL(1)) {
+	P_ evac = *stackptr;
+	if (evac > OldGen) {
+	    *stackptr = EVACUATE_CLOSURE(evac);
+	}
+    }
+    DEBUG_STRING("Evacuate B Stack:");
+    bstk_roots = 0;
+    for (updateFramePtr = MAIN_SuB, botB = stackInfo.botB;
+	 SUBTRACT_B_STK(updateFramePtr, botB) > 0;
+	 /* re-initialiser given explicitly */) {
+	
+	/* Evacuate the thing to be updated */
+	P_ evac = GRAB_UPDATEE(updateFramePtr);
+	if (evac > OldGen) {
+	    PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
+	}
+	bstk_roots++;
+
+	updateFramePtr = GRAB_SuB(updateFramePtr);
+    }
+#endif	/* PAR */    
+
+    DEBUG_STRING("Evacuate Mutable Roots:");
+    mutable = 0;
+    mutptr = sm->OldMutables;
+    prevmut = ((P_)&sm->OldMutables) - FIXED_HS;
+				/* See MUT_LINK */
+    while ( mutptr ) {
+
+	/* Scavenge the OldMutable closure */
+	P_ info = (P_) INFO_PTR(mutptr);
+	StgScavPtr scav_code = SCAV_CODE(info);
+	Scav = mutptr;
+	(scav_code)();
+
+	/* Remove from OldMutables if no longer mutable */
+	/* HACK ALERT: See comment in SMap.lc
+	    about why we do this terrible pointer comparison.
+	*/
+	if (info == ImMutArrayOfPtrs_info) { /* ToDo: use different test? (WDP 94/11) */
+    	    P_ tmp = mutptr;
+	    MUT_LINK(prevmut) = MUT_LINK(mutptr);
+	    mutptr = (P_) MUT_LINK(mutptr);
+	    MUT_LINK(tmp) = MUT_NOT_LINKED;
+	} else {
+	    prevmut = mutptr;
+	    mutptr = (P_) MUT_LINK(mutptr);
+	}
+	mutable++;
+    }
+
+#ifdef PAR
+    EvacuateLocalGAs(rtsFalse);
+#else
+    evacSPTable( sm );
+#endif /* PAR */
+
+    while ((newscav <= ToHp) || (oldscav <= OldHp)) {
+	Scav = newscav;
+	DEBUG_SCAN("Scav:  NewScav", Scav, "ToHp", ToHp);
+	while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+	newscav = Scav;
+
+	Scav = oldscav;
+	DEBUG_SCAN("Scav:  OldScav", Scav, "OldHp", OldHp);
+	while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
+	oldscav = Scav;
+    }
+    
+    
+    /* SECOND: Evacuate & Scavenge CAFs and OldGen roots */
+    /* Ensure these roots don't use old generation root indirection when evacuated */
+    Scav = newscav;
+
+    oldstartToHp  = ToHp;
+    oldstartOldHp = OldHp;
+
+    
+    DEBUG_STRING("Evacuate CAFs and old generation roots:");
+    /* Evacuate CAFs in allocation region to New semispace */
+    /* Evacuate CAFs in New semispace to OldGen */
+    /* OldCAFlist = NewCAFlist ++ OldCAFlist */
+    /* NewCAFlist = CAFlist */
+    /* CAFlist = NULL */
+    
+    alloc_cafs = 0;
+    for (CAFptr = sm->CAFlist; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {   
+	EVACUATE_CLOSURE(CAFptr); /* evac & upd */
+	alloc_cafs++;
+    }
+    
+    for (CAFptr = genInfo.NewCAFlist,
+	 prevCAF = ((P_)(&genInfo.NewCAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */
+	 CAFptr; CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+	EVACUATE_CLOSURE(CAFptr); /* evac & upd */
+	prevCAF = CAFptr;
+    }
+    new_cafs = genInfo.NewCAFno;
+
+    IND_CLOSURE_LINK(prevCAF) = (W_) genInfo.OldCAFlist;
+    genInfo.OldCAFlist = genInfo.NewCAFlist;
+    genInfo.OldCAFno += genInfo.NewCAFno;
+    
+    genInfo.NewCAFlist = sm->CAFlist;
+    genInfo.NewCAFno = alloc_cafs;
+    sm->CAFlist = NULL;
+    
+    
+    /* Evacuate OldRoots roots to New semispace */
+    /* Evacuate OldInNew roots to OldGen, discard these roots */
+    /* OldInNew = OldRoots */
+    /* OldRoots = 0 */
+    
+    for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
+	P_ evac = (P_) IND_CLOSURE_PTR(oldroot);
+	if (evac > OldGen) {
+	    IND_CLOSURE_PTR(oldroot) = (W_) EVACUATE_CLOSURE(evac);
+	}
+    }
+    new_oldroots = genInfo.OldInNewno;
+    
+    DEBUG_STRING("Scavenge evacuated old generation roots:");
+    while ((newscav <= ToHp) || (oldscav <= OldHp)) {
+	Scav = newscav;
+	DEBUG_SCAN("Scav:  NewScav", Scav, "ToHp", ToHp);
+	while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+	newscav = Scav;
+
+	Scav = oldscav;
+	DEBUG_SCAN("Scav:  OldScav", Scav, "OldHp", OldHp);
+	while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
+	oldscav = Scav;
+    }
+
+    old_words = OldHp - oldstartOldHp;  /* + (ToHp - oldstartToHp) */
+
+    
+    /* record newly promoted mutuple roots */
+    MUT_LINK(prevmut) = (W_) genInfo.PromMutables;
+    genInfo.PromMutables = 0;
+
+
+    promote  = OldHp - genInfo.oldlim;
+    resident = (ToHp - genInfo.newgen[genInfo.curnew].newbase + 1) + promote;
+    
+    genInfo.newgen[genInfo.curnew].newlim = ToHp;
+    genInfo.oldlim = OldHp;
+    
+    genInfo.minor_since_major++;
+    
+#ifdef PAR
+    RebuildGAtables(rtsFalse);
+#else
+    reportDeadMallocPtrs(sm->MallocPtrList, 
+			 sm->OldMallocPtrList, 
+			 &(sm->OldMallocPtrList));
+    sm->MallocPtrList = NULL;   /* all (new) MallocPtrs have been promoted */
+#endif /* PAR */
+
+    if (SM_stats_verbose) {
+	char minor_str[BIG_STRING_LEN];
+#ifndef PAR
+	sprintf(minor_str, "%6lu %4lu   %4lu %4ld %3ld %3ld %4ld  %3ld %3ld %6ld   Minor",
+		promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots,
+		(I_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+		bstk_roots, sm->rootno, alloc_cafs + new_cafs,
+		mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
+#else
+	/* ToDo: come up with some interesting statistics for the parallel world */
+	sprintf(minor_str, "%6lu %4lu   %4lu %4ld %3ld %3ld %4ld  %3ld %3ld %6ld   Minor",
+		promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots, 0,
+		0, sm->rootno, alloc_cafs + new_cafs,
+		mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
+#endif
+	stat_endGC(alloc, collect, resident, minor_str);
+    } else {
+	stat_endGC(alloc, collect, resident, "");
+    }
+
+    /* ToDo: Decide to do major early ! */
+
+    if (genInfo.oldlim <= genInfo.oldthresh  && !do_full_collection) {
+    
+	sm->hp = hp_start = genInfo.allocbase - 1;
+	sm->hplim = genInfo.alloclim;
+	sm->OldLim = genInfo.oldlim;
+    
+	if (SM_trace)
+	    fprintf(stderr, "GEN End: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n         hp 0x%lx, hplim 0x%lx, free %lu\n",
+		    (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
+		    (W_) genInfo.newgen[genInfo.curnew].newbase,
+		    (W_) genInfo.newgen[genInfo.curnew].newlim,
+		    (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+    
+	RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+    
+	return GC_SUCCESS;	/* Heap OK -- Enough space to continue */
+    }
+
+
+    DEBUG_STRING("Major Collection Required");
+    stat_startGC(0);
+
+    alloc = genInfo.oldlim - genInfo.oldbase + 1;
+
+    /* Zero bit vector for marking phase of major collection */
+
+    bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+    { BitWord *ptr = genInfo.bit_vect,
+	      *end = genInfo.bit_vect + bit_words;
+      while (ptr < end) { *(ptr++) = 0; };
+    }
+    
+    /* Set are for old gen CAFs to be linked */
+
+    CAFlocs = (PP_) genInfo.newgen[(genInfo.curnew + 1) % 2].newbase;
+    if (genInfo.new_words < genInfo.OldCAFno) {
+	fprintf(stderr, "colectHeap: Too many CAFs %ld to link in new semi-space %ld\n",
+		genInfo.OldCAFno, genInfo.alloc_words);
+	fprintf(stderr, "            Rerun using  +RTS -A<size>  to increase allocation area\n");
+	EXIT(EXIT_FAILURE);
+    }
+
+    /* Change old generation root indirections to special OldRoot indirections */
+    /* These will be marked and not short circuted (like SPEC 2,1 closure)     */
+
+    for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
+	INFO_PTR(oldroot) = (W_) OldRoot_info;
+    }
+
+    /* Discard OldInNew roots: Scanning OldRoots will reconstruct live OldInNew root list */
+    genInfo.OldInNew = 0;
+    genInfo.OldInNewno = 0;
+
+    /* Discard OldMutable roots: Scanning Mutables will reconstruct live OldMutables root list */
+    sm->OldMutables = 0;
+
+    /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
+    RESTORE_REGS(&ScavRegDump);
+
+    markHeapRoots(sm, genInfo.NewCAFlist, genInfo.OldCAFlist,
+		  genInfo.oldbase, genInfo.oldlim, genInfo.bit_vect);
+
+    SAVE_REGS(&ScavRegDump);
+    /* end of bracket */
+
+#ifndef PAR
+    sweepUpDeadMallocPtrs(sm->OldMallocPtrList, 
+			  appelInfo.oldbase, 
+			  appelInfo.bits 
+			  );
+#endif /* !PAR */
+
+    oldlim = genInfo.oldlim;
+
+    DEBUG_STRING("Linking Dummy CAF Ptr Locations:");
+    CAFloc = CAFlocs;
+    for (CAFptr = genInfo.OldCAFlist; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+	DEBUG_LINK_CAF(CAFptr, CAFloc);
+	*CAFloc = (P_) IND_CLOSURE_PTR(CAFptr);
+	LINK_LOCATION_TO_CLOSURE(CAFloc, oldlim);
+	CAFloc++;
+    }
+
+    DEBUG_STRING("Linking Roots:");
+    for (root = 0; root < sm->rootno; root++) {
+	LINK_LOCATION_TO_CLOSURE(sm->roots+root, oldlim);
+    }
+
+#ifdef PAR
+    fall over here until we figure out how to link GAs
+#else
+    DEBUG_STRING("Linking Stable Pointer Table:");
+    LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable, oldlim);
+    DEBUG_STRING("Linking A Stack:");
+    for (stackptr = MAIN_SpA;
+	 SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
+	 stackptr = stackptr + AREL(1)) {
+	LINK_LOCATION_TO_CLOSURE(stackptr, oldlim);
+    }
+    DEBUG_STRING("Linking B Stack:");
+    for (updateFramePtr = MAIN_SuB;   /* SuB points to topmost update frame */
+	 SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
+	 /* re-initialiser given explicitly */) {
+	    
+	P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE);
+	LINK_LOCATION_TO_CLOSURE(updateClosurePtr, oldlim);
+
+	updateFramePtr = GRAB_SuB(updateFramePtr);
+    }
+#endif	/* PAR */
+
+    /* Do Inplace Compaction */
+    /* Returns start of next closure, -1 gives last allocated word */
+
+    genInfo.oldlim = Inplace_Compaction(genInfo.oldbase,
+					genInfo.oldlim,
+					genInfo.newgen[genInfo.curnew].newbase,
+					genInfo.newgen[genInfo.curnew].newlim,
+					genInfo.bit_vect, bit_words) - 1;
+
+    resident = (genInfo.oldlim - genInfo.oldbase) + 1;
+    total_resident = genInfo.newgen[genInfo.curnew].newlim -
+		     genInfo.newgen[genInfo.curnew].newbase + 1 + resident;
+
+    sm->hp = hp_start = genInfo.allocbase - 1;
+    sm->hplim = genInfo.alloclim;
+    sm->OldLim = genInfo.oldlim;
+
+    genInfo.oldwas = genInfo.oldlim;
+    genInfo.minor_since_major = 0;
+
+    if (SM_stats_verbose) {
+	char major_str[BIG_STRING_LEN];
+#ifndef PAR
+	sprintf(major_str, "%6d %4ld   %4u %4ld %3ld %3ld %4d  %3d %3d %6.6s  *Major* %4.1f%%",
+		0, genInfo.OldInNewno,
+		(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+		bstk_roots, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
+		0, 0, 0, "", total_resident / (StgFloat) SM_word_heap_size * 100);
+#else
+	sprintf(major_str, "%6d %4ld   %4u %4ld %3ld %3ld %4d  %3d %3d %6.6s  *Major* %4.1f%%",
+		0, genInfo.OldInNewno,
+		0, 0, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
+		0, 0, 0, "", total_resident / (StgFloat) SM_word_heap_size * 100);
+#endif
+	stat_endGC(0, alloc, resident, major_str);
+    } else { 
+	stat_endGC(0, alloc, resident, "");
+    }
+
+    if (SM_trace)
+	fprintf(stderr, "GEN Major: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n           hp 0x%lx, hplim 0x%lx, free %lu\n",
+		(W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
+		(W_) genInfo.newgen[genInfo.curnew].newbase,
+		(W_) genInfo.newgen[genInfo.curnew].newlim,
+		(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
+
+#ifdef DEBUG
+    /* To help flush out bugs, we trash the part of the heap from
+       which we're about to start allocating. */
+    TrashMem(sm->hp+1, sm->hplim);
+#endif /* DEBUG */
+  
+    RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
+
+    if (genInfo.oldlim > genInfo.oldthresh)
+	return GC_HARD_LIMIT_EXCEEDED;	/* Heap exhausted */
+    else 
+	return GC_SUCCESS;		/* Heap OK */
+}
+
+#endif /* GCgn */
+
+\end{code}
+
diff --git a/ghc/runtime/storage/SMinit.lc b/ghc/runtime/storage/SMinit.lc
new file mode 100644
index 0000000000..cff23ba7a7
--- /dev/null
+++ b/ghc/runtime/storage/SMinit.lc
@@ -0,0 +1,185 @@
+\section[storage-manager-init]{Initialising the storage manager}
+
+To initialise the storage manager, we pass it:
+\begin{itemize}
+\item
+An @argc@/@argv@ combo, which are the command-line arguments that have
+been deemed to belong to the runtime system.  The initialisation
+routine can slurp around in there for information of interest to
+it.
+
+\item
+A filehandle to which any storage-manager statistics should be written.
+\end{itemize}
+
+\begin{code}
+#define NULL_REG_MAP
+#include "SMinternal.h"
+
+/* global vars to hold some storage-mgr details; */
+/* decls for these are in SMinternal.h           */
+I_   SM_force_gc       = 0;
+I_   SM_word_heap_size = DEFAULT_HEAP_SIZE;
+I_   SM_alloc_min      = 0;
+StgFloat SM_pc_free_heap   = DEFAULT_PC_FREE;
+I_   SM_alloc_size     = 0;
+I_   SM_major_gen_size = 0;
+I_   SM_word_stk_size  = DEFAULT_STACKS_SIZE;
+FILE *SM_statsfile = NULL;
+I_   SM_trace = 0;
+I_   SM_stats_summary = 0;
+I_   SM_stats_verbose = 0;
+I_   SM_ring_bell = 0;
+
+I_ MaxResidency = 0;     /* in words; for stats only */
+I_ ResidencySamples = 0; /* for stats only */
+
+#ifndef atof
+extern double atof();
+/* no proto because some machines use const and some do not */
+#endif
+
+I_
+decode(s)
+  char *s;
+{
+    I_ c;
+    StgDouble m;
+    if (!*s)
+	return 0;
+    m = atof(s);
+    c = s[strlen(s)-1];
+    if (c == 'g' || c == 'G')
+	m *= 1000*1000*1000;	/* UNchecked! */
+    else if (c == 'm' || c == 'M')
+	m *= 1000*1000;			/* We do not use powers of 2 (1024) */
+    else if (c == 'k' || c == 'K')	/* to avoid possible bad effects on */
+	m *= 1000;			/* a direct-mapped cache.   	    */ 
+    else if (c == 'w' || c == 'W')
+	m *= sizeof(W_);
+    return (I_)m;
+}
+
+static void
+badoption(s)
+  char *s;
+{
+  fflush(stdout);
+  fprintf(stderr, "initSM: Bad RTS option: %s\n", s);
+  EXIT(EXIT_FAILURE);
+}		
+
+extern long strtol  PROTO((const char *, char **, int)); /* ToDo: properly? */
+
+I_
+initSM(rts_argc, rts_argv, statsfile)
+    I_     rts_argc;
+    char **rts_argv;
+    FILE  *statsfile;
+{
+    I_ arg;
+
+    /* save statsfile info */
+    SM_statsfile = statsfile;
+    
+    /* slurp through RTS args */
+
+    for (arg = 0; arg < rts_argc; arg++) {
+	if (rts_argv[arg][0] == '-') {
+	    switch(rts_argv[arg][1]) {
+	      case 'H':
+		SM_word_heap_size = decode(rts_argv[arg]+2) / sizeof(W_);
+
+		if (SM_word_heap_size <= 0) badoption( rts_argv[arg] );
+		break;
+
+	      case 'M':
+		SM_pc_free_heap = atof(rts_argv[arg]+2);
+
+		if ((SM_pc_free_heap < 0) || (SM_pc_free_heap > 100))
+		    badoption( rts_argv[arg] );
+		break;
+
+	      case 'A':
+		SM_alloc_size = decode(rts_argv[arg]+2) / sizeof(W_);
+
+		if (SM_alloc_size == 0) SM_alloc_size = DEFAULT_ALLOC_SIZE;
+		break;
+
+	      case 'G':
+		SM_major_gen_size = decode(rts_argv[arg]+2) / sizeof(W_);
+		break;
+
+	      case 'F':
+		if (strcmp(rts_argv[arg]+2, "2s") == 0) {
+		    SM_force_gc = USE_2s;
+		} else if (strcmp(rts_argv[arg]+2, "1s") == 0) {
+		    badoption( rts_argv[arg] ); /* ToDo ! */
+		} else {
+		    badoption( rts_argv[arg] );
+		}
+		break;
+
+	      case 'K':
+		SM_word_stk_size = decode(rts_argv[arg]+2) / sizeof(W_);
+
+		if (SM_word_stk_size == 0) badoption( rts_argv[arg] );
+		break;
+
+	      case 'S':
+		SM_stats_verbose++;
+		/* statsfile has already been determined */
+		break;
+	      case 's':
+		SM_stats_summary++;
+		/* statsfile has already been determined */
+		break;
+	      case 'B':
+		SM_ring_bell++;
+		break;
+
+	      case 'T':
+		if (rts_argv[arg][2] != '\0')
+		    SM_trace = (I_) strtol(rts_argv[arg]+2, (char **)NULL, 0);
+		else
+		    SM_trace = 1;
+		break;
+
+#ifdef GCdu
+	      case 'u':
+		dualmodeInfo.resid_to_compact = atof(rts_argv[arg]+2);
+		dualmodeInfo.resid_from_compact = dualmodeInfo.resid_from_compact + 0.05;
+		if (dualmodeInfo.resid_from_compact < 0.0 ||
+		    dualmodeInfo.resid_to_compact > 1.0) {
+		  badoption( rts_argv[arg] );
+		}
+#endif
+
+	      default:
+		/* otherwise none of my business */
+		break;
+	    }
+	}
+	/* else none of my business */
+    }
+
+    SM_alloc_min = (I_) (SM_word_heap_size * SM_pc_free_heap / 100);
+
+    return(0); /* all's well */
+}
+\end{code}
+
+
+\section[storage-manager-exit]{Winding up the storage manager}
+
+\begin{code}
+
+I_
+exitSM (sm_info)
+    smInfo *sm_info;
+{
+    stat_exit(sm_info->hp - hp_start);
+
+    return(0); /* I'm happy */
+}
+\end{code}
diff --git a/ghc/runtime/storage/SMinternal.lh b/ghc/runtime/storage/SMinternal.lh
new file mode 100644
index 0000000000..832b5cfedd
--- /dev/null
+++ b/ghc/runtime/storage/SMinternal.lh
@@ -0,0 +1,525 @@
+%
+% (c) The AQUA Project, Glasgow University, 1992-1994
+%
+\begin{code}
+#ifndef SMinternals_H
+#define SMinternals_H
+\end{code}
+
+This stuff needs to be documented.  KH
+
+\begin{code}
+/* In the Storage Manager we use the global register mapping */
+/* We turn off STG-machine register declarations             */
+
+#if ! (defined(MAIN_REG_MAP) || defined(NULL_REG_MAP) || defined(MARK_REG_MAP) || defined(SCAN_REG_MAP) || defined(SCAV_REG_MAP))
+**** please set your REG_MAP ****
+#endif
+
+#include "rtsdefs.h"
+
+#ifdef HAVE_SYS_VADVISE_H
+#include <sys/vadvise.h>
+#endif
+
+extern I_   SM_force_gc;
+#define USE_2s	1
+#define USE_1s	2
+
+extern I_   SM_word_heap_size; /* all defined in SMinit.lc */
+extern I_   SM_alloc_min;
+extern StgFloat SM_pc_free_heap;
+extern I_   SM_alloc_size;
+extern I_   SM_major_gen_size;
+/*moved: extern I_   SM_word_stk_size; */
+extern FILE    *SM_statsfile;
+extern I_   SM_trace;
+extern I_   SM_stats_summary;
+extern I_   SM_stats_verbose;
+extern I_   SM_ring_bell;
+
+extern P_ heap_space;
+extern P_ hp_start;
+
+extern void stat_init    PROTO((char *collector, char *c1, char *c2));
+extern void stat_startGC PROTO((I_ alloc));
+extern void stat_endGC   PROTO((I_ alloc, I_ collect, I_ live, char *comment));
+extern void stat_exit    PROTO((I_ alloc));
+
+extern I_ MaxResidency;     /* in words; for stats only */
+extern I_ ResidencySamples; /* for stats only */
+
+#define DO_MAX_RESIDENCY(r) /* saves typing */	\
+    do {					\
+	I_ resid = (r);				\
+	ResidencySamples++;			\
+	if (resid > MaxResidency) {		\
+	    MaxResidency = resid;		\
+	}					\
+    } while (0)
+
+extern StgFunPtr _Dummy_entry(STG_NO_ARGS);
+extern char *xmalloc PROTO((size_t));
+
+#if defined(_GC_DEBUG)
+#define DEBUG_SCAN(str, pos, to, topos) \
+	if (SM_trace & 2) fprintf(stderr, "%s: 0x%lx, %s 0x%lx\n", str, pos, to, topos)
+#define DEBUG_STRING(str) \
+	if (SM_trace & 2) fprintf(stderr, "%s\n", str)
+#else
+#define DEBUG_SCAN(str, pos, to, topos)
+#define DEBUG_STRING(str)
+#endif
+
+/************************ Default HEAP and STACK sizes **********************/
+
+#define DEFAULT_STACKS_SIZE  	 0x10002  /* 2^16 = 16Kwords = 64Kbytes */
+
+#define DEFAULT_HEAP_SIZE  	 0x100002 /* 2^20 = 1Mwords = 4Mbytes  */
+#define DEFAULT_ALLOC_SIZE       0x4002   /* 2^14 = 16k words = 64k bytes */
+#define DEFAULT_PC_FREE          3	  /* 3% */
+
+/* I added a couple of extra words above, to be more sure of avoiding
+    bad effects on direct-mapped caches. (WDP)
+*/
+
+#define NEXT_SEMI_SPACE(space) ((space + 1) % 2)
+
+/************************ Random stuff **********************/
+
+/* This should be really big */
+#define BIG_STRING_LEN	    	 512
+
+/************************** TWO SPACE COPYING (2s) **************************/
+
+#if defined(GC2s)
+
+typedef struct {
+    P_ base; 	/* First word allocatable in semispace */
+    P_ lim; 	/* Last word allocatable in semispace */
+} semispaceData;
+
+extern I_ semispace;	/* 0 or 1 -- indexes semispaceInfo */
+extern semispaceData semispaceInfo[2];
+
+#endif /* GC2s */
+
+
+/*********************** SINGLE SPACE COMPACTION (1s) ***********************/
+
+#if defined(GC1s)
+
+typedef struct {
+    P_ base;  /* First word allocatable in heap */
+    P_ lim;   /* Last word allocatable in heap */
+    BitWord *bits; 	/* Area for marking bits */
+    I_ bit_words; 	/* Size of marking bit area (in words) */
+    I_ heap_words;	/* Size of heap area (in words) */
+} compactingData;
+
+extern compactingData compactingInfo;
+
+#endif /* GC1s */
+
+
+/****************************** DUAL MODE (du) ******************************/
+
+#if defined(GCdu)
+
+typedef struct {
+	I_ mode;
+	StgFloat resid_to_compact;
+	StgFloat resid_from_compact;
+	struct {
+	    P_ base; /* First word allocatable in this mode */
+	    P_ lim;  /* Last word allocatable in this mode */
+	    I_ heap_words; /* Size of area (in words) */
+	    char *name;
+	} modeinfo[3];
+    	BitWord *bits;	    /* Area for marking bits */
+    	I_ bit_words;   /* Size of marking bit area (in words) */
+} dualmodeData;
+
+extern dualmodeData dualmodeInfo;
+
+#define DEFAULT_RESID_TO_COMPACT   0.25
+#define DEFAULT_RESID_FROM_COMPACT 0.20
+
+#define TWO_SPACE_BOT 0
+#define TWO_SPACE_TOP 1
+#define COMPACTING    2
+
+#endif /* GCdu */
+
+/*************************** APPELS COLLECTOR (ap) **************************/
+
+#if defined(GCap)
+
+typedef struct {
+ 	P_ oldbase;   /* first word allocatable in oldgen */
+	P_ oldlim;    /* last word allocated in oldgen */
+	P_ oldlast;   /* oldlim after last major collection */
+	P_ oldthresh; /* threshold of oldgen occupancy */
+	P_ oldmax;    /* maximum allocatable in oldgen before heap deemed full */
+
+	I_ newfixed;  /* The size of the new generation, if fixed */
+	I_ newmin;    /* The minimum size of the new generation */
+	P_ newbase;   /* First word allocatable in newgen top space */
+	P_ newlim;    /* Last word allocatable in newgen top space */
+
+    	BitWord *bits;    /* Area for marking bits */
+
+	P_ OldCAFlist; /* CAFs promoted to old generation */
+	I_ OldCAFno;   /* No of CAFs promoted to old generation */
+    	I_ bit_words;  /* Size of marking bit area (in words) */
+
+        P_ PromMutables; /* List of recently promoted mutable closures */
+
+	I_ semi_space;   /* -F forced 2s collector */
+	struct {
+	    P_ base;  /* First word allocatable in semispace */
+	    P_ lim;   /* Last word allocatable in semispace */
+	} space[2];
+
+} appelData;
+
+/* UPDATE INFO - Stored in sm info structure:
+      Additional info required when updating to keep track of
+	new generation roots residing in the old generation
+	(old -> new inter-generation pointers)
+*/
+
+extern appelData appelInfo;
+
+#endif /* GCap */
+
+
+/************************ GENERATIONAL COLLECTOR (gn) ***********************/
+
+#if defined(GCgn)
+
+typedef struct {
+	I_ alloc_words;  /* Size of allocation space */
+			   /* May be large enough for bit array */
+	I_ new_words;    /* Size of new generation semi-space */
+			   /* Must be large enough for bit array */
+	I_ old_words;    /* Size of old generation */
+
+	I_  minor_since_major;
+	                   /* No of minor collections since last major */ 
+
+	P_ allocbase;  /* First word allocatable in oldgen */
+	P_ alloclim;   /* Last word allocatable in oldgen */
+
+	I_ curnew;	   /* New gen semi-space currently in use */
+	struct {
+	 P_ newbase;   /* First word allocatable in newgen semispace */
+	 P_ newlim;    /* Last word allocated in new semi-space */
+	} newgen[2];
+
+	P_ oldbase;    /* First word allocatable in oldgen */
+	P_ oldend;     /* Last word allocatable in oldgen */
+	P_ oldwas;     /* Limit of oldgen after last major collection */
+	P_ oldlim;     /* Last word allocated in oldgen */
+	P_ oldthresh;  /* Oldgen threshold: less than new_words free */
+	BitWord *bit_vect; /* Marking bits -- alloc area or old generation */
+
+	P_ OldInNew;   /* Old roots pointing to new generation */
+	I_ OldInNewno; /* No of Old roots pointing to new generation */
+	P_ NewCAFlist; /* CAFs in new generation */
+	I_ NewCAFno;   /* No of CAFs in new generation */
+	P_ OldCAFlist; /* CAFs promoted to old generation */
+	I_ OldCAFno;   /* No of CAFs promoted to old generation */
+
+        P_ PromMutables; /* List of recently promoted mutable closures */
+
+	I_ semi_space;  /* -F forced 2s collector */
+	struct {
+	    P_ base; /* First word allocatable in semispace */
+	    P_ lim;  /* Last word allocatable in semispace */
+	} space[2];
+} genData;
+
+extern genData genInfo;
+
+/* Update INFO - Stored in sm info structure:
+      Additional info required when updating to keep track of
+	new generation roots residing in the old generation
+	(old -> new inter-generation pointers)
+*/
+
+#endif /* GCap */
+
+/****************************** COPYING ******************************/
+
+
+#if defined(_INFO_COPYING)
+
+#define EVAC_CODE(infoptr)  ((StgEvacPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET])
+#define SCAV_CODE(infoptr)  ((StgScavPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET+1])
+
+extern void Scavenge(STG_NO_ARGS);
+extern void  _Scavenge_Forward_Ref(STG_NO_ARGS);
+
+/* Note: any change to FORWARD_ADDRESS should be
+   reflected in layout of MallocPtrs (includes/SMClosures.lh)
+*/
+
+#define FORWARD_ADDRESS(closure)  (*(((P_)(closure)) + FIXED_HS))
+
+#define FORWARDREF_ITBL(infolbl,entry,localness,evac_forward) 	\
+CAT_DECLARE(infolbl,INTERNAL_KIND,"FORWARD_REF","FORWARD_REF")	\
+localness W_ infolbl[] = {					\
+        (W_) entry					    	\
+	,(W_) INFO_OTHER_TAG					\
+	,(W_) MK_REP_REF(,evac_forward,)			\
+	INCLUDE_PROFILING_INFO(infolbl)				\
+	}
+
+P_ _Evacuate_Old_Forward_Ref PROTO((P_));
+P_ _Evacuate_New_Forward_Ref PROTO((P_));
+P_ _Evacuate_OldRoot_Forward PROTO((P_));
+P_ _Evacuate_Forward_Ref PROTO((P_));
+
+MAYBE_DECLARE_RTBL(,_Evacuate_Old_Forward_Ref,)
+MAYBE_DECLARE_RTBL(,_Evacuate_New_Forward_Ref,)
+MAYBE_DECLARE_RTBL(,_Evacuate_OldRoot_Forward,)
+MAYBE_DECLARE_RTBL(,_Evacuate_Forward_Ref,)
+
+#define FORWARDREF_RTBL(evac_forward) \
+    const W_ MK_REP_LBL(,evac_forward,)[] = { \
+	INCLUDE_TYPE_INFO(INTERNAL)				\
+	INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED)		\
+	INCLUDE_PAR_INFO				\
+	INCLUDE_COPYING_INFO(evac_forward,_Scavenge_Forward_Ref)\
+	INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \
+	}
+
+EXTDATA_RO(Caf_Evac_Upd_info);
+extern StgEvacFun _Evacuate_Caf_Evac_Upd;
+
+#define CAF_EVAC_UPD_ITBL(infolbl,entry,localness)		\
+CAT_DECLARE(infolbl,INTERNAL_KIND,"CAF_EVAC_UPD","CAF_EVAC_UPD") \
+localness W_ infolbl[] = {					\
+        (W_) entry					    	\
+	,(W_) INFO_OTHER_TAG					\
+	,(W_) MK_REP_REF(Caf_Evac_Upd,,)			\
+	INCLUDE_PROFILING_INFO(infolbl)				\
+	}
+
+MAYBE_DECLARE_RTBL(Caf_Evac_Upd,,)
+
+#define CAF_EVAC_UPD_RTBL() \
+    const W_ MK_REP_LBL(Caf_Evac_Upd,,)[] = { \
+	INCLUDE_TYPE_INFO(INTERNAL)				\
+	INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED)		\
+	INCLUDE_PAR_INFO		\
+	INCLUDE_COPYING_INFO(_Evacuate_Caf_Evac_Upd,_Scavenge_Caf) \
+	INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \
+    }
+
+#define EVACUATE_CLOSURE(closure)      \
+    	(EVAC_CODE(INFO_PTR(closure)))(closure)
+
+#endif /* _INFO_COPYING */
+
+
+/****************************** MARKING ******************************/
+
+#if defined(_INFO_MARKING)
+
+extern I_ markHeapRoots PROTO((smInfo *sm, P_ cafs1, P_ cafs2,
+				P_ base, P_ lim, BitWord *bit_array));
+
+#define PRMARK_CODE(infoptr) \
+	  (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+1])
+
+/* Applied to unmarked or marking info pointer */
+#define PRRETURN_CODE(infoptr) \
+	  (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+3])
+
+/* This placed on bottom of PR Marking Stack */
+
+#define DUMMY_PRRETURN_CLOSURE(closure_name, table_name, prreturn_code, dummy_code) \
+const W_ table_name[] = { 	    	    	\
+	(W_) dummy_code	    	    	    	\
+	,(W_) INFO_OTHER_TAG			\
+	,(W_) MK_REP_REF(,prreturn_code,)	\
+	INCLUDE_PROFILING_INFO(Dummy_PrReturn)	\
+	};					\
+W_ closure_name = (W_) table_name
+
+EXTFUN(_Dummy_PRReturn_entry);
+EXTFUN(_PRMarking_MarkNextRoot);
+EXTFUN(_PRMarking_MarkNextCAF);
+
+#ifdef CONCURRENT
+EXTFUN(_PRMarking_MarkNextSpark);
+#endif
+
+#ifdef PAR
+EXTFUN(_PRMarking_MarkNextGA);
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextGA,)
+#else
+
+EXTFUN(_PRMarking_MarkNextAStack);
+EXTFUN(_PRMarking_MarkNextBStack);
+
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextAStack,)
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextBStack,)
+
+#endif /* PAR */
+
+#ifdef CONCURRENT
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextSpark,)
+#endif
+
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextRoot,)
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextCAF,)
+
+#define DUMMY_PRRETURN_RTBL(prreturn_code,dummy_code) \
+    const W_ MK_REP_LBL(,prreturn_code,)[] = {	    \
+	INCLUDE_TYPE_INFO(INTERNAL)		    \
+	INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED)  \
+	INCLUDE_PAR_INFO   \
+	INCLUDE_COPYING_INFO(dummy_code,dummy_code) \
+	INCLUDE_COMPACTING_INFO(dummy_code,dummy_code,dummy_code,prreturn_code) \
+    }
+
+/* Unused "Code to avoid explicit updating of CAF references" used to live here
+    (WDP 94/11)
+*/ 
+
+#endif /* _INFO_MARKING */
+
+
+/****************************** COMPACTING ******************************/
+
+#if defined(_INFO_COMPACTING)
+
+#ifndef PAR
+P_ Inplace_Compaction PROTO((P_ base, P_ lim,
+			     P_ scanbase, P_ scablim,
+			     BitWord *bit_array, I_ bit_array_words,
+			     StgPtr *MallocPtrList));
+#else
+P_ Inplace_Compaction PROTO((P_ base, P_ lim,
+			     P_ scanbase, P_ scablim,
+			     BitWord *bit_array, I_ bit_array_words));
+#endif
+/* Applied to marked info pointers */
+
+#define SCAN_LINK_CODE(infoptr) \
+	  ((StgScanPtr) ((P_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET])
+#define SCAN_MOVE_CODE(infoptr) \
+	  ((StgScanPtr) ((P_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+2])
+
+/*
+	This fragment tests whether we're in global garbage collection during parallel
+	evaluation.  If so, then we check the global address of the closure \tr{loc}
+	and evacuate it in the IMUs if it's a legal global address.
+*/
+
+#define  LINK_GLOBALADDRESS(loc)
+
+#if defined(GCgn)
+
+extern StgScavFun _Scavenge_OldRoot;               /* Allocated Old -> New root, just skip */
+extern StgEvacFun _Evacuate_OldRoot;               /* Should not occur */
+
+extern StgFunPtr  _PRStart_OldRoot(STG_NO_ARGS);   /* Marking old root -- Short circut if points to oldgen */
+extern StgScanFun _ScanMove_OldRoot;               /* Scanning old root -- Rebuild old root list */
+
+EXTDATA_RO(OldRoot_info);
+
+#define OLDROOT_ITBL(infolbl,ind_code,localness,entry_localness)\
+    CAT_DECLARE(infolbl,INTERNAL_KIND,"OLDROOT","OLDROOT")	\
+    entry_localness(ind_code);					\
+    localness W_ infolbl[] = {					\
+        (W_) ind_code					    	\
+	,(W_) INFO_OTHER_TAG					\
+	,(W_) MK_REP_REF(OldRoot,,)				\
+	INCLUDE_PROFILING_INFO(infolbl)				\
+	}
+
+MAYBE_DECLARE_RTBL(OldRoot,,)
+
+#define OLDROOT_RTBL()							\
+    const W_ MK_REP_LBL(OldRoot,,)[] = {				\
+	INCLUDE_TYPE_INFO(SPEC_U)					\
+	INCLUDE_SIZE_INFO(2,1)	/* deeply hardwired size/ptrs */	\
+	INCLUDE_PAR_INFO			\
+	INCLUDE_COPYING_INFO(_Evacuate_OldRoot,_Scavenge_OldRoot)	\
+	SPEC_COMPACTING_INFO(_ScanLink_2_1,_PRStart_OldRoot,_ScanMove_OldRoot,_PRIn_1) \
+	}
+
+#define LINK_LOCATION_TO_CLOSURE(loc,linklim)       	    	\
+          { P_ _temp = (P_) *(loc);				\
+          DEBUG_LINK_LOCATION(loc, _temp, linklim);	      	\
+	  if (DYNAMIC_CLOSURE(_temp) && (_temp <= linklim)) { 	\
+              *((P_)(loc)) = (W_) INFO_PTR(_temp);      	\
+	      INFO_PTR(_temp)  = MARK_LOCATION(loc);   	    	\
+	  }}
+
+#else /* ! GCgn */
+
+#define LINK_LOCATION_TO_CLOSURE(loc)       	\
+          { P_ _temp = (P_) *(loc);    	\
+          DEBUG_LINK_LOCATION(loc, _temp);	\
+	  if (DYNAMIC_CLOSURE(_temp)) {	    	\
+              *((P_)(loc)) = (W_) INFO_PTR(_temp); \
+	      INFO_PTR(_temp) = MARK_LOCATION(loc); 	\
+	  }}
+
+#endif /* ! GCgn */
+
+#if defined(_GC_DEBUG)
+
+#if defined(GCgn)
+#define DEBUG_LINK_LOCATION(location, closure, linklim)	\
+    if (SM_trace & 4) {	        		\
+	if (DYNAMIC_CLOSURE(closure) && (closure <= linklim)) \
+            fprintf(stderr, "  Link Loc: 0x%lx to 0x%lx\n", location, closure); \
+	else if (! DYNAMIC_CLOSURE(closure))   	\
+	     fprintf(stderr, "  Link Loc: 0x%lx to 0x%lx Static Closure -- Not Done\n", location, closure); \
+	else                               	\
+	     fprintf(stderr, "  Link Loc: 0x%lx to 0x%lx OutOfRange Closure -- Not Done\n", location, closure); \
+    }
+#else /* ! GCgn */
+#define DEBUG_LINK_LOCATION(location, closure)	\
+    if (SM_trace & 4) {	        		\
+	if (DYNAMIC_CLOSURE(closure))		\
+            fprintf(stderr, "  Link Loc: 0x%lx to 0x%lx\n", location, closure); \
+	else					\
+	    fprintf(stderr, "  Link Loc: 0x%lx to 0x%lx Static Closure -- Not Done\n", location, closure); \
+    }
+#endif /* ! GCgn */
+
+#define DEBUG_UNLINK_LOCATION(location, closure, newlocation) 	\
+    if (SM_trace & 4)                     			\
+        fprintf(stderr, "  UnLink Loc: 0x%lx, 0x%lx -> 0x%lx\n", location, closure, newlocation)
+
+#define DEBUG_LINK_CAF(caf) \
+    if (SM_trace & 4)        	\
+	fprintf(stderr, "Caf: 0x%lx  Closure: 0x%lx\n", caf, IND_CLOSURE_PTR(caf))
+
+#define DEBUG_SET_MARK(closure, hp_word) \
+    if (SM_trace & 8)			 \
+        fprintf(stderr, "  Set Mark Bit: 0x%lx, word %ld, bit_word %ld, bit %d\n", closure, hp_word, hp_word / BITS_IN(BitWord), hp_word & (BITS_IN(BitWord) - 1))
+
+#else
+#if defined(GCgn)
+#define DEBUG_LINK_LOCATION(location, closure, linklim)
+#else
+#define DEBUG_LINK_LOCATION(location, closure)
+#endif
+#define DEBUG_UNLINK_LOCATION(location, closure, newlocation)
+#define DEBUG_LINK_CAF(caf)
+#define DEBUG_SET_MARK(closure, hp_word)
+#endif
+
+#endif /* _INFO_COMPACTING */
+
+#endif /* SMinternals_H */
+
+\end{code}
diff --git a/ghc/runtime/storage/SMmark.lhc b/ghc/runtime/storage/SMmark.lhc
new file mode 100644
index 0000000000..ae6a3fab8e
--- /dev/null
+++ b/ghc/runtime/storage/SMmark.lhc
@@ -0,0 +1,1628 @@
+%****************************************************************************
+%
+\section[SMmark.lhc]{Pointer-Reversing Mark code}
+%
+% (c) P. Sansom, K. Hammond, OBFUSCATION-THROUGH-GRATUITOUS-PREPROCESSOR-ABUSE
+%     Project, Glasgow University, January 26th 1993.
+%
+%****************************************************************************
+
+This module contains the specialised and generic code to perform
+pointer reversal marking.  These routines are placed in the info
+tables of the appropriate closures.
+
+Some of the dirt is hidden in macros defined in SMmarkDefs.lh.
+
+%****************************************************************************
+%
+\subsection[mark-overview]{Overview of Marking}
+%
+%****************************************************************************
+
+This module uses a pointer-reversal algorithm to mark a closure.
+To mark a closure, first set a bit indicating that the closure
+has been marked, then mark each pointer in the closure.  The mark
+bit is used to determine whether a node has already been
+marked before we mark it.  Because we set the bit before marking
+the children of a node, this avoids cycles.
+
+Given a closure containing a number of pointers, $n$, $n > 0$ the mark
+code for that closure can be divided into three parts:
+\begin{enumerate}
+\item
+The mark (or ``start'') code for the closure.  Called when an attempt is made
+to mark the closure, it initialises the mark position in the
+closure, then jumps to the mark code for the first pointer.
+\item
+The return (or ``in'') code for the closure.  Called when a closure is
+returned to after a child is marked, it increments the mark position
+and jumps to the mark entry for the next pointer
+\item
+The last (or ``in-last'') code for the closure.  Called when all children
+have been marked, it just returns to its parent through the appropriate
+return code.
+\end{enumerate}
+
+For non-\tr{SPEC} closures, the return and last codes are merged in most
+cases, so the return code checks explicitly whether all pointers have
+been marked, and returns if so.
+
+%****************************************************************************
+%
+\subsubsection[mark-registers]{Registers used when marking}
+%
+%****************************************************************************
+
+Two registers are used:
+\begin{description}
+\item[Mark]
+Points to the closure being marked.
+\item[MStack]
+Points to the closure on the top of the marking stack.
+The first closure on the stack contains the continuation to
+enter when marking is complete.
+\end{description}
+
+The following registers are used by Pointer Reversal Marking:
+
+\begin{description}
+\item[@MStack@]
+The top of the mark stack.
+\item[@Mark@]
+The node being processed.
+\item[@BitArray@]
+The bit array (what's that? KH) to mark.
+\item[@HeapBase@]
+The base of the heap (to calculate bit to mark).
+\item[@HeapLim@]
+The limit of the heap.  For generational garbage collection,
+only closures whose address is $<$ @HeapLim@ will be marked
+\end{description}
+
+To answer KH's question, the @BitArray@ is used to store marks.  This
+avoids the need to include space for a mark bit in the closure itself.
+The array consists of one bit per word of heap memory that is handled
+by the compacting collector or the old generation in the generational
+collector. [ADR]
+
+%****************************************************************************
+%
+\subsubsection[mark-conventions]{Calling and Return Conventions}
+%
+%****************************************************************************
+
+When a child closure is returned from, the registers have the following
+values.
+
+\begin{description}
+\item[@Mark@]
+points to the closure just marked (this may be updated with a new
+address to short-circuit indirections).
+\item[MStack]
+points to the closure whose return code has been entered
+(this closure is now at the top of the pointer-reversal marking stack).
+\end{description}
+
+The macros @JUMP_MARK@ and @JUMP_MARK_RETURN@ jump to the start code
+pointed to by the @Mark@ register, or the return code pointed to by
+the @MStack@ register respectively.
+
+
+%%%%  GOT THIS FAR -- KH %%%%
+
+Marking A Closure:
+  @_PRStart_N@
+
+  Retrieved using PRMARK_CODE(infoptr)
+
+Uses pointer reversal marking to mark a closure which contains N ptrs.
+If the closure has 0 pointers it sets it to a marked state and returns
+to the closure on top of the PR mark stack (_PRStart_0).
+
+If Not (@_PRStart_N@  ($N > 0$))
+   sets to a state of marking the first pointer
+   pushes this closure on the PR marking stack (in the first ptr location)
+   marks the first child -- enters its marking code
+
+A closure that is already marked just indicates this by returning to the
+closure on the top of the PR mark stack.
+
+  Calling Conventions:
+    Mark   -- points to the closure to mark
+    MStack -- points to the closure on the top of the PR marking stack
+              If the stack is empty it points to a closure which contains
+              the continuation to enter when marking is complete.
+
+  User Invokation:
+    Have root to mark
+    MStack set to a closure containing the continuation to be called when
+      the root has been marked.
+    Mark pointing to the closure
+
+  Entering MStack Continuation:
+    Mark points to new value of the closure (indirection short circut)
+    *** Update root being marked with this value.
+
+
+Returning To A Closure Being Marked:
+  _PRIn_I
+  _PRInLast_N
+
+  Retrieved using PRRETURN_CODE(infoptr)
+
+Starts marking the next pointer (_PRIn_I).
+  updates the current poointer being marked with new Mark
+  sets state to next pointer
+  marks the next child
+If not, (_PRInLast_N), it returns to the closure on the top of the PR
+marking stack.
+
+  Calling Conventions:
+    Mark   -- points to the closure just marked (may be updated with new
+              address to short indirections)
+    MStack -- points to it -- the closure on the top of the PR marking stack
+
+
+
+The following registers are used by Pointer Reversal Marking:
+
+MStack   -- The MarkStack register
+Mark     -- Points to the Node being processed
+BitArray -- The bit array to mark
+HeapBase -- The base of the heap (to calculate bit to mark)
+HeapLim  -- The limit of the heap
+         -- For gen gc: only closures < HeapLim will be marked
+         --             OldRoots pointing  < HeapLim
+
+\input{SMmarkDefs.lh}
+
+%****************************************************************************
+%
+\subsection[mark-code]{The actual Marking Code}
+%
+%****************************************************************************
+
+This code is only used if @_INFO_MARKING@ is defined.
+
+\begin{code}
+#if defined(_INFO_MARKING)
+\end{code}
+
+First the necessary forward declarations.
+
+\begin{code}
+/* #define MARK_REG_MAP -- Must be done on command line for threaded code */
+#include "SMinternal.h"
+#include "SMmarkDefs.h"
+\end{code}
+
+Define appropriate variables as potential register variables.
+Assume GC code saves and restores any global registers used.
+
+\begin{code}
+RegisterTable MarkRegTable;
+\end{code}
+
+@_startMarkWorld@ restores registers if necessary, then marks the
+root pointed to by @Mark@.
+
+\begin{code}
+STGFUN(_startMarkWorld)
+{
+    FUNBEGIN;
+#if defined(__STG_GCC_REGS__) && defined(__GNUC__)
+    /* If using registers load from _SAVE (see SMmarking.lc) */
+
+    /* I deeply suspect this should be RESTORE_REGS(...) [WDP 95/02] */
+#ifdef REG_MarkBase
+    MarkBaseReg = &MarkRegTable;
+#endif
+    Mark = SAVE_Mark;
+    MRoot = SAVE_MRoot;
+    MStack = SAVE_MStack;
+    BitArray = SAVE_BitArray;
+    HeapBase = SAVE_HeapBase;
+    HeapLim  = SAVE_HeapLim;
+#endif
+
+    JUMP_MARK;
+    FUNEND;
+}
+\end{code}
+
+This is the pointer reversal start code for \tr{SPEC} closures with 0
+pointers.
+
+\begin{code}
+STGFUN(_PRStart_0)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+    } else
+    INIT_MARK_NODE("SPEC",0);
+
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+\end{code}
+
+
+This macro defines the format of the pointer reversal start code for a
+number of pointers \tr{ptrs}, $>$ 0.
+
+\begin{code}
+
+#define SPEC_PRStart_N_CODE(ptrs) 		\
+STGFUN(CAT2(_PRStart_,ptrs))	    	 	\
+{						\
+    FUNBEGIN;	    	    	    	    	\
+    if (IS_MARK_BIT_SET(Mark)) {		\
+	DEBUG_PR_MARKED;			\
+	JUMP_MARK_RETURN;			\
+    } else {					\
+        INIT_MARK_NODE("SPEC",ptrs);		\
+	INIT_MSTACK(SPEC_CLOSURE_PTR);		\
+    }						\
+    FUNEND;  	    	    	    	    	\
+}
+
+\end{code}
+
+The definitions of the start code for \tr{SPEC} closures with 1-12
+pointers.
+
+\begin{code}
+SPEC_PRStart_N_CODE(1)
+SPEC_PRStart_N_CODE(2)
+SPEC_PRStart_N_CODE(3)
+SPEC_PRStart_N_CODE(4)
+SPEC_PRStart_N_CODE(5)
+SPEC_PRStart_N_CODE(6)
+SPEC_PRStart_N_CODE(7)
+SPEC_PRStart_N_CODE(8)
+SPEC_PRStart_N_CODE(9)
+SPEC_PRStart_N_CODE(10)
+SPEC_PRStart_N_CODE(11)
+SPEC_PRStart_N_CODE(12)
+
+\end{code}
+
+Start code for revertible black holes with underlying @SPEC@ types.
+
+\begin{code}
+
+#ifdef PAR
+#define SPEC_RBH_PRStart_N_CODE(ptrs) 		\
+STGFUN(CAT2(_PRStart_RBH_,ptrs))    	 	\
+{						\
+    FUNBEGIN;	    	    	    	    	\
+    if (IS_MARK_BIT_SET(Mark)) {		\
+	DEBUG_PR_MARKED;			\
+	JUMP_MARK_RETURN;			\
+    } else {					\
+        INIT_MARK_NODE("SRBH",ptrs-1);		\
+    INIT_MSTACK(SPEC_RBH_CLOSURE_PTR);		\
+    }						\
+    FUNEND;  	    	    	    	    	\
+}
+
+SPEC_RBH_PRStart_N_CODE(2)
+SPEC_RBH_PRStart_N_CODE(3)
+SPEC_RBH_PRStart_N_CODE(4)
+SPEC_RBH_PRStart_N_CODE(5)
+SPEC_RBH_PRStart_N_CODE(6)
+SPEC_RBH_PRStart_N_CODE(7)
+SPEC_RBH_PRStart_N_CODE(8)
+SPEC_RBH_PRStart_N_CODE(9)
+SPEC_RBH_PRStart_N_CODE(10)
+SPEC_RBH_PRStart_N_CODE(11)
+SPEC_RBH_PRStart_N_CODE(12)
+
+#endif
+
+\end{code}
+
+@SPEC_PRIn_N_CODE@ has two different meanings, depending on the world
+in which we use it:
+\begin{itemize}
+\item
+In the commoned-info-table world, it
+defines the ``in'' code for a particular number
+of pointers, and subsumes the functionality of @SPEC_PRInLast_N_NODE@ below.
+\item
+Otherwise, it defines the ``in'' code for a particular pointer in a
+\tr{SPEC} closure.
+\end{itemize}
+
+\begin{code}
+
+#define SPEC_PRIn_N_CODE(ptrs) 				\
+STGFUN(CAT2(_PRIn_,ptrs))    	    	 		\
+{              					\
+    BitWord mbw;					\
+    FUNBEGIN;					\
+    GET_MARKED_PTRS(mbw,MStack,ptrs);			\
+    if (++mbw < ptrs) {				    	\
+	SET_MARKED_PTRS(MStack,ptrs,mbw);		\
+	CONTINUE_MARKING_NODE("SPEC",mbw);		\
+	MOVE_TO_NEXT_PTR(SPEC_CLOSURE_PTR,mbw);	    	\
+    } else {						\
+	SET_MARKED_PTRS(MStack,ptrs,0L);		\
+	POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,ptrs);	\
+    }							\
+    FUNEND;					\
+}
+
+\end{code}
+
+Now @SPEC_PRIn_N_CODE@ is used to define the individual entries for \tr{SPEC} closures
+with 1-12 pointers.
+
+\begin{code}
+STGFUN(_PRIn_0)
+{
+    FUNBEGIN;
+    fprintf(stderr,"Called _PRIn_0\nShould never occur!\n");
+    abort();
+    FUNEND;
+}
+STGFUN(_PRIn_1)
+{
+    FUNBEGIN;
+    POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,1);
+    FUNEND;
+}
+SPEC_PRIn_N_CODE(2)
+SPEC_PRIn_N_CODE(3)
+SPEC_PRIn_N_CODE(4)
+SPEC_PRIn_N_CODE(5)
+SPEC_PRIn_N_CODE(6)
+SPEC_PRIn_N_CODE(7)
+SPEC_PRIn_N_CODE(8)
+SPEC_PRIn_N_CODE(9)
+SPEC_PRIn_N_CODE(10)
+SPEC_PRIn_N_CODE(11)
+SPEC_PRIn_N_CODE(12)
+\end{code}
+
+In code for revertible black holes with underlying @SPEC@ types.
+
+\begin{code}
+#ifdef PAR
+#define SPEC_RBH_PRIn_N_CODE(ptrs)			\
+STGFUN(CAT2(_PRIn_RBH_,ptrs))  	    	 		\
+{							\
+    BitWord mbw;					\
+    FUNBEGIN;						\
+    GET_MARKED_PTRS(mbw,MStack,ptrs-1);			\
+    if (++mbw < ptrs-1) {			    	\
+	SET_MARKED_PTRS(MStack,ptrs-1,mbw);		\
+	CONTINUE_MARKING_NODE("SRBH",mbw);		\
+	MOVE_TO_NEXT_PTR(SPEC_RBH_CLOSURE_PTR,mbw);    	\
+    } else {						\
+	SET_MARKED_PTRS(MStack,ptrs-1,0L);		\
+	POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,ptrs-1);	\
+    }							\
+    FUNEND;						\
+}
+
+STGFUN(_PRIn_RBH_2)
+{
+    FUNBEGIN;
+    POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,1);
+    FUNEND;
+}
+
+SPEC_RBH_PRIn_N_CODE(3)
+SPEC_RBH_PRIn_N_CODE(4)
+SPEC_RBH_PRIn_N_CODE(5)
+SPEC_RBH_PRIn_N_CODE(6)
+SPEC_RBH_PRIn_N_CODE(7)
+SPEC_RBH_PRIn_N_CODE(8)
+SPEC_RBH_PRIn_N_CODE(9)
+SPEC_RBH_PRIn_N_CODE(10)
+SPEC_RBH_PRIn_N_CODE(11)
+SPEC_RBH_PRIn_N_CODE(12)
+#endif
+
+\end{code}
+
+Malloc Ptrs are in the sequential world only.
+
+\begin{code}
+
+#ifndef PAR
+
+STGFUN(_PRStart_MallocPtr)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+    } else
+    INIT_MARK_NODE("MallocPtr ",0);
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+#endif /* !PAR */
+\end{code}
+
+This defines the start code for generic (\tr{GEN}) closures.
+
+\begin{code}
+STGFUN(_PRStart_N)
+{
+    W_ ptrs;
+
+    FUNBEGIN;
+
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+        JUMP_MARK_RETURN;
+    }
+    ptrs = GEN_CLOSURE_NoPTRS(Mark);
+    INIT_MARK_NODE("GEN ",ptrs);
+    if (ptrs == 0) {
+        JUMP_MARK_RETURN;
+    } else {
+	INIT_MSTACK(GEN_CLOSURE_PTR);
+    }
+    FUNEND;
+}
+\end{code}
+
+Now the ``in'' code for \tr{GEN} closures.
+
+\begin{code}
+STGFUN(_PRIn_I)
+{
+    W_ ptrs;
+    BitWord pos;
+
+    FUNBEGIN;
+
+    ptrs = GEN_CLOSURE_NoPTRS(MStack);
+    GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
+
+    if (++pos < ptrs) {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
+	CONTINUE_MARKING_NODE("GEN",pos);
+	MOVE_TO_NEXT_PTR(GEN_CLOSURE_PTR,pos);
+    } else {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
+	POP_MSTACK("GEN ",GEN_CLOSURE_PTR,ptrs);
+    }
+    FUNEND;
+}
+\end{code}
+
+And the start/in code for a revertible black hole with an underlying @GEN@ closure.
+
+\begin{code}
+
+#ifdef PAR
+
+STGFUN(_PRStart_RBH_N)
+{
+    W_ ptrs;
+
+    FUNBEGIN;
+
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+	JUMP_MARK_RETURN;
+    }
+
+    /* 
+     * Get pointer count from original closure and adjust for one pointer 
+     * in the first two words of the RBH.
+     */
+    ptrs = GEN_RBH_CLOSURE_NoPTRS(Mark);
+    if (ptrs < 2)
+	ptrs = 1;
+    else
+	ptrs--;
+
+    INIT_MARK_NODE("GRBH", ptrs);
+    INIT_MSTACK(GEN_RBH_CLOSURE_PTR);
+    FUNEND;
+}
+
+STGFUN(_PRIn_RBH_I)
+{
+    W_ ptrs;
+    BitWord pos;
+
+    FUNBEGIN;
+
+    /* 
+     * Get pointer count from original closure and adjust for one pointer 
+     * in the first two words of the RBH.
+     */
+    ptrs = GEN_RBH_CLOSURE_NoPTRS(MStack);
+    if (ptrs < 2)
+	ptrs = 1;
+    else
+	ptrs--;
+
+    GET_GEN_MARKED_PTRS(pos, MStack, ptrs);
+
+    if (++pos < ptrs) {
+	SET_GEN_MARKED_PTRS(MStack, ptrs, pos);
+	CONTINUE_MARKING_NODE("GRBH", pos);
+	MOVE_TO_NEXT_PTR(GEN_RBH_CLOSURE_PTR, pos);
+    } else {
+	SET_GEN_MARKED_PTRS(MStack, ptrs, 0L);
+	POP_MSTACK("GRBH", GEN_RBH_CLOSURE_PTR, ptrs);
+    }
+    FUNEND;
+}
+
+#endif
+
+\end{code}
+
+Start code for dynamic (\tr{DYN}) closures.  There is no \tr{DYN}
+closure with 0 pointers -- \tr{DATA} is used instead.
+
+\begin{code}
+STGFUN(_PRStart_Dyn)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+        JUMP_MARK_RETURN;
+    } else {
+    INIT_MARK_NODE("DYN ", DYN_CLOSURE_NoPTRS(Mark));
+	INIT_MSTACK(DYN_CLOSURE_PTR);
+    }
+    FUNEND;
+}
+\end{code}
+
+and the corresponding ``in'' code.
+
+\begin{code}
+STGFUN(_PRIn_I_Dyn)
+{
+    W_ ptrs;
+    BitWord pos;
+
+    FUNBEGIN;
+    ptrs = DYN_CLOSURE_NoPTRS(MStack);
+    GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
+
+    if (++pos < ptrs) {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
+	CONTINUE_MARKING_NODE("DYN",pos);
+	MOVE_TO_NEXT_PTR(DYN_CLOSURE_PTR,pos);
+    } else {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
+	POP_MSTACK("DYN ",DYN_CLOSURE_PTR,ptrs);
+      }
+    FUNEND;
+}
+\end{code}
+
+
+The start code for \tr{TUPLE} (all-pointer) objects.  There can be no
+such object without any pointers, so we don't check for this case.
+
+\begin{code}
+STGFUN(_PRStart_Tuple)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+        JUMP_MARK_RETURN;
+    } else {
+    INIT_MARK_NODE("TUPL", TUPLE_CLOSURE_NoPTRS(Mark));
+	INIT_MSTACK(TUPLE_CLOSURE_PTR);
+    }
+    FUNEND;
+}
+\end{code}
+
+Now the ``in'' case.
+
+\begin{code}
+STGFUN(_PRIn_I_Tuple)
+{
+    W_ ptrs;
+    BitWord pos;
+
+    FUNBEGIN;
+    ptrs = TUPLE_CLOSURE_NoPTRS(MStack);
+    GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
+
+    if (++pos < ptrs) {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
+	CONTINUE_MARKING_NODE("TUPL",pos);
+	MOVE_TO_NEXT_PTR(TUPLE_CLOSURE_PTR,pos);
+    } else {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
+	POP_MSTACK("TUPL",TUPLE_CLOSURE_PTR,ptrs);
+      }
+    FUNEND;
+}
+\end{code}
+
+
+\begin{code}
+/*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
+/*             Only if special GC treatment required           */
+
+#ifdef GC_MUT_REQUIRED
+
+STGFUN(_PRStart_MuTuple)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+        JUMP_MARK_RETURN;
+    } else {
+    INIT_MARK_NODE("MUT ", MUTUPLE_CLOSURE_NoPTRS(Mark));
+	INIT_MSTACK(MUTUPLE_CLOSURE_PTR);
+    }
+    FUNEND;
+}
+
+STGFUN(_PRIn_I_MuTuple)
+{
+    W_ ptrs;
+    BitWord pos;
+
+    FUNBEGIN;
+    ptrs = MUTUPLE_CLOSURE_NoPTRS(MStack);
+    GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
+
+    if (++pos < ptrs) {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
+	CONTINUE_MARKING_NODE("MUT",pos);
+	MOVE_TO_NEXT_PTR(MUTUPLE_CLOSURE_PTR,pos);
+    } else {
+	SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
+	POP_MSTACK("MUT ",MUTUPLE_CLOSURE_PTR,ptrs);
+      }
+    FUNEND;
+}
+
+#endif /* GCap || GCgn */
+\end{code}
+
+There are no pointers in a \tr{DATA} closure, so just mark the
+closure and return.
+
+\begin{code}
+STGFUN(_PRStart_Data)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+    } else
+    INIT_MARK_NODE("DATA", 0);
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+\end{code}
+
+%****************************************************************************
+%
+\subsubsection[mark-specials]{Special cases}
+%
+%****************************************************************************
+
+Black hole closures simply mark themselves and return.
+
+\begin{code}
+STGFUN(_PRStart_BH)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+    } else
+    INIT_MARK_NODE("BH  ", 0);
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+\end{code}
+
+Marking a Static Closure -- Just return as if Marked
+
+\begin{code}
+STGFUN(_PRStart_Static)
+{
+    FUNBEGIN;
+    DEBUG_PR_STAT;
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+\end{code}
+
+Marking an Indirection -- Set Mark to ind addr and mark this.
+Updating of reference when we return will short indirection.
+
+\begin{code}
+STGFUN(_PRStart_Ind)
+{
+    FUNBEGIN;
+    DEBUG_PR_IND;
+    Mark = (P_) IND_CLOSURE_PTR(Mark);
+    JUMP_MARK;
+    FUNEND;
+}
+\end{code}
+
+``Permanent indirection''---used in profiling.  Works basically
+like @_PRStart_1@ (one pointer).
+\begin{code}
+#if defined(USE_COST_CENTRES)
+STGFUN(_PRStart_PI)
+{
+    FUNBEGIN;
+/* This test would be here if it really was like a PRStart_1.
+   But maybe it is not needed because a PI cannot have two
+   things pointing at it (so no need to mark it), because
+   they are only created in exactly one place in UpdatePAP.
+   ??? WDP 95/07
+
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+	JUMP_MARK_RETURN;
+    } else {
+*/
+	INIT_MARK_NODE("PI  ",1);
+	/* the "1" above is dodgy (i.e. wrong), but it is never
+	   used except in debugging info.  ToDo??? WDP 95/07
+	*/
+	INIT_MSTACK(PERM_IND_CLOSURE_PTR);
+/*  } */
+    FUNEND;
+}
+STGFUN(_PRIn_PI)
+{
+    FUNBEGIN;
+    POP_MSTACK("PI  ",PERM_IND_CLOSURE_PTR,1);
+    /* the "1" above is dodgy (i.e. wrong), but it is never
+       used except in debugging info.  ToDo??? WDP 95/07
+    */
+    FUNEND;
+}
+#endif
+\end{code}
+
+Marking a ``selector closure'': This is a size-2 SPEC thunk that
+selects word $n$; if the thunk's pointee is evaluated, then we short
+out the selection, {\em just like an indirection}.  If it is still
+unevaluated, then we behave {\em exactly as for a SPEC-2 thunk}.
+
+{\em Should we select ``on the way down'' (in \tr{_PRStart_Selector})
+or ``on the way back up'' (\tr{_PRIn_Selector})?}  Answer: probably on
+the way down.  Downside: we are flummoxed by indirections, so we'll
+have to wait until the {\em next} major GC to do the selections (after
+the indirections are sorted out in this GC).  But the downside of
+doing selections on the way back up is that we are then in a world of
+reversed pointers, and selecting a reversed pointer---we've see this
+on selectors for very recursive structures---is a total disaster.
+(WDP 94/12)
+
+\begin{code}
+#if defined(_GC_DEBUG)
+#define IF_GC_DEBUG(x) x
+#else
+#define IF_GC_DEBUG(x) /*nothing*/
+#endif
+
+/* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
+
+#if 0
+/* testing */
+#define MARK_SELECTOR(n)						\
+STGFUN(CAT2(_PRStartSelector_,n))					\
+{									\
+    P_ maybe_con;							\
+    FUNBEGIN;								\
+									\
+    /* must be a SPEC 2 1 closure */					\
+    ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2);				\
+    ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1);				\
+    ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */		\
+									\
+    JMP_(_PRStart_1);							\
+									\
+    FUNEND;								\
+}
+#endif /* 0 */
+
+#define MARK_SELECTOR(n)						\
+STGFUN(CAT2(_PRStartSelector_,n))					\
+{									\
+    P_ maybe_con;							\
+    FUNBEGIN;								\
+									\
+    /* must be a SPEC 2 1 closure */					\
+    ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2);				\
+    ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1);				\
+    ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */		\
+									\
+    if (IS_MARK_BIT_SET(Mark)) { /* already marked */			\
+	DEBUG_PR_MARKED;						\
+	JUMP_MARK_RETURN;						\
+    }									\
+									\
+    maybe_con = (P_) *(Mark + _FHS);					\
+									\
+    IF_GC_DEBUG(							\
+    if (SM_trace & 2)  {						\
+        fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, marked? 0x%%lx, info 0x%lx", \
+		(n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)),	\
+		INFO_NoPTRS(INFO_PTR(Mark)),				\
+		maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/	\
+		INFO_PTR(maybe_con));					\
+	fprintf(stderr, ", tag %ld, size %ld, ptrs %ld",		\
+	    INFO_TAG(INFO_PTR(maybe_con)),				\
+	    INFO_SIZE(INFO_PTR(maybe_con)),				\
+	    INFO_NoPTRS(INFO_PTR(maybe_con)));				\
+	if (INFO_TAG(INFO_PTR(maybe_con)) >=0) {			\
+	    /* int i; */						\
+	    /* for (i = 0; i < INFO_SIZE(INFO_PTR(maybe_con)); i++) { */ \
+		/* fprintf(stderr, ", 0x%lx", maybe_con[_FHS + i]); */ 	\
+	    /*}*/							\
+	    fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]);		\
+	}								\
+	fprintf(stderr, "\n");						\
+    } )									\
+									\
+    if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\
+     || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */	\
+     ||	INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */		\
+	/* see below for OLD test we used here (WDP 95/04) */		\
+	/* ToDo: decide WHNFness another way? */			\
+	JMP_(_PRStart_1);						\
+									\
+    /* some things should be true about the pointee */			\
+    ASSERT(INFO_TAG(INFO_PTR(maybe_con)) == 0);				\
+    /* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \
+									\
+    /* OK, it is evaluated: behave just like an indirection */		\
+									\
+    Mark = (P_) (maybe_con[_FHS + (n)]);				\
+    /* Mark now has the result of the selection */			\
+    JUMP_MARK;								\
+									\
+    FUNEND;								\
+}
+
+#if 0
+/* OLD test:
+   the IS_STATIC test was to protect the IS_MARK_BIT_SET check;
+   but the IS_MARK_BIT_SET test was only there to avoid
+   mangled pointers, but we cannot have mangled pointers anymore
+   (after RTBLs came our way).
+   SUMMARY: we toss both of the "guard" tests.
+ */
+    if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */
+     || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */
+     ||	INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
+#endif /* 0 */
+
+MARK_SELECTOR(0)
+MARK_SELECTOR(1)
+MARK_SELECTOR(2)
+MARK_SELECTOR(3)
+MARK_SELECTOR(4)
+MARK_SELECTOR(5)
+MARK_SELECTOR(6)
+MARK_SELECTOR(7)
+MARK_SELECTOR(8)
+MARK_SELECTOR(9)
+MARK_SELECTOR(10)
+MARK_SELECTOR(11)
+MARK_SELECTOR(12)
+
+#undef IF_GC_DEBUG /* get rid of it */
+\end{code}
+
+Marking a Constant Closure -- Set Mark to corresponding static
+closure.  Updating of reference will redirect reference to the static
+closure.
+
+\begin{code}
+STGFUN(_PRStart_Const)
+{
+    FUNBEGIN;
+    DEBUG_PR_CONST;
+    Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+\end{code}
+
+Marking a CharLike Closure -- Set Mark to corresponding static
+closure.  Updating of reference will redirect reference to the static
+closure.
+
+\begin{code}
+STGFUN(_PRStart_CharLike)
+{
+    FUNBEGIN;
+    DEBUG_PR_CHARLIKE;
+    Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark));
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+\end{code}
+
+Marking an IntLike Closure -- Set Mark to corresponding static closure
+if in range.  Updating of reference to this will redirect reference to
+the static closure.
+
+\begin{code}
+STGFUN(_PRStart_IntLike)
+{
+    I_ val;
+
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+    } else {
+    val = INTLIKE_VALUE(Mark);
+
+    if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
+	DEBUG_PR_INTLIKE_TO_STATIC;
+	    INFO_PTR(Mark) = (W_) Ind_info;
+	    IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val);
+	    Mark = (P_) IND_CLOSURE_PTR(Mark);
+	} else {	
+	    /* out of range of static closures */
+	DEBUG_PR_INTLIKE_IN_HEAP;
+	    INIT_MARK_NODE("INT ",0);
+    }
+    }
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+\end{code}
+
+CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
+
+\begin{code}
+#if defined(GCgn)
+
+/* Marking an OldGen root -- treat as indirection if it references the old generation */
+
+STGFUN(_PRStart_OldRoot)
+{
+    P_ oldroot;
+
+    FUNBEGIN;
+    oldroot = (P_) IND_CLOSURE_PTR(Mark);
+
+    if (oldroot <= HeapLim)                               /* does the root reference the old generation ? */
+      {
+	DEBUG_PR_OLDIND;
+	Mark = oldroot;                                   /* short circut if the old generation root */
+	JUMP_MARK;                                        /* references an old generation closure    */
+      }
+
+    else
+      {
+	INIT_MARK_NODE("OldRoot",1);                   /* oldroot to new generation */
+	INIT_MSTACK(SPEC_CLOSURE_PTR);                    /* treat as _PRStart_1       */
+      }
+    FUNEND;
+}
+
+#endif /* GCgn */
+
+\end{code}
+
+Special error routine, used for closures which should never call their
+``in'' code.
+
+\begin{code}
+STGFUN(_PRIn_Error)
+{
+    FUNBEGIN;
+    fprintf(stderr,"Called _PRIn_Error\nShould never occur!\n");
+    abort();
+    FUNEND;
+}
+\end{code}
+
+%****************************************************************************
+%
+\subsubsection[mark-fetchme]{Marking FetchMe Objects (parallel only)}
+%
+%****************************************************************************
+
+\begin{code}
+#ifdef PAR
+\end{code}
+
+FetchMe's present a unique problem during global GC.  Since the IMU short-circuits
+indirections during its evacuation, it may return a PLC as the new global address
+for a @FetchMe@ node.  This has the effect of turning the @FetchMe@ into an
+indirection during local garbage collection.  Of course, we'd like to short-circuit
+this indirection immediately.
+
+\begin{code}
+STGFUN(_PRStart_FetchMe)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+    } else
+	INIT_MARK_NODE("FME ", 0);
+
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+
+STGFUN(_PRStart_BF)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+	JUMP_MARK_RETURN;
+    } else {
+        INIT_MARK_NODE("BF  ", BF_CLOSURE_NoPTRS(dummy));
+        INIT_MSTACK(BF_CLOSURE_PTR);
+    }
+    FUNEND;
+}
+
+STGFUN(_PRIn_BF)
+{
+    BitWord mbw;
+
+    FUNBEGIN;
+    GET_MARKED_PTRS(mbw, MStack, BF_CLOSURE_NoPTRS(dummy));
+    if (++mbw < BF_CLOSURE_NoPTRS(dummy)) {
+	SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), mbw);
+	CONTINUE_MARKING_NODE("BF  ", mbw);
+	MOVE_TO_NEXT_PTR(BF_CLOSURE_PTR, mbw);
+    } else {
+	SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), 0L);
+	POP_MSTACK("BF  ", BF_CLOSURE_PTR, BF_CLOSURE_NoPTRS(dummy));
+    }
+    FUNEND;
+}
+
+#endif /* PAR */
+\end{code}
+
+%****************************************************************************
+%
+\subsubsection[mark-tso]{Marking Thread State Objects (threaded only)}
+%
+%****************************************************************************
+
+First mark the link, then mark all live registers (StkO plus the VanillaRegs
+indicated by Liveness).
+
+CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
+
+\begin{code}
+
+#ifdef CONCURRENT
+
+STGFUN(_PRStart_BQ)
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+        JUMP_MARK_RETURN;
+    } else {
+    INIT_MARK_NODE("BQ  ", BQ_CLOSURE_NoPTRS(Mark));
+	INIT_MSTACK(BQ_CLOSURE_PTR);
+    }
+    FUNEND;
+}
+
+STGFUN(_PRIn_BQ)
+{
+    FUNBEGIN;
+    POP_MSTACK("BQ  ",BQ_CLOSURE_PTR,1);
+    FUNEND;
+}
+
+STGFUN(_PRStart_TSO)
+{
+    P_ temp;
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+	JUMP_MARK_RETURN;
+    } else {
+    INIT_MARK_NODE("TSO ", 0);
+    temp = TSO_LINK(Mark);
+    TSO_LINK(Mark) = MStack;
+    MStack = Mark;
+    Mark = temp;
+    JUMP_MARK;
+    }
+    FUNEND;
+}
+\end{code}
+
+When we're in the TSO, pos 0 is the link, 1 is the StkO, and 2-10 correspond to
+the vanilla registers r[pos-2].
+
+\begin{code}
+STGFUN(_PRIn_TSO)
+{
+    W_ liveness;
+    BitWord oldpos, newpos;
+    STGRegisterTable *r;
+    P_ temp, mstack;
+
+    FUNBEGIN;
+    GET_MARKED_PTRS(oldpos,MStack,TSO_PTRS);
+    r = TSO_INTERNAL_PTR(MStack);
+
+    switch(oldpos) {
+    case 0:
+    	/* Just did the link; now do the StkO */
+	SET_MARKED_PTRS(MStack,TSO_PTRS,1L);
+    	temp = r->rStkO;
+    	r->rStkO = TSO_LINK(MStack);
+    	TSO_LINK(MStack) = Mark;
+    	Mark = temp;
+	DEBUG_PRIN("TSO ", 1);
+    	JUMP_MARK;
+    	break;
+    case 1:
+    	/* Just did the StkO; just update it, saving the old mstack */
+        mstack = r->rStkO;
+    	r->rStkO = Mark;
+    	break;
+    default:
+    	/* update the register we just did; save the old mstack */
+	mstack = r->rR[oldpos - 2].p;
+	r->rR[oldpos - 2] = Mark;
+    	break;
+    }
+
+    /* liveness of the remaining registers */
+    liveness = r->rLiveness >> (oldpos - 1);
+
+    if (liveness == 0) {
+    	/* Restore MStack and return */
+	SET_MARKED_PTRS(MStack,TSO_PTRS,0L);
+        DEBUG_PRLAST("TSO ", oldpos);
+    	Mark = MStack;
+	MStack = mstack;
+        JUMP_MARK_RETURN;
+    }
+
+    /* More to do in this TSO */
+
+    /* Shift past non-ptr registers */
+    for(newpos = oldpos + 1; (liveness & 1) == 0; liveness >>= 1) {
+    	newpos++;
+    }
+
+    /* Mark the next one */
+    SET_MARKED_PTRS(MStack,TSO_PTRS,newpos);
+    Mark = r->rR[newpos - 2].p;
+    r->rR[newpos - 2].p = mstack;
+    DEBUG_PRIN("TSO ", oldpos);
+    JUMP_MARK;
+
+    FUNEND;
+}
+
+\end{code}
+
+%****************************************************************************
+%
+\subsubsection[mark-stko]{Marking Stack Objects (threaded only)}
+%
+%****************************************************************************
+
+First mark the A stack, then mark all updatees in the B stack.
+
+\begin{code}
+
+STGFUN(_PRStart_StkO)
+{
+    P_ temp;
+    I_ size;
+    I_ cts_size;
+
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+	JUMP_MARK_RETURN;
+    } else {
+    INIT_MARK_NODE("STKO", 0);
+    size = STKO_CLOSURE_SIZE(Mark);
+    cts_size = STKO_CLOSURE_CTS_SIZE(Mark);
+    SET_GEN_MARKED_PTRS(Mark,size,(BitWord)(cts_size + 1));
+    temp = STKO_LINK(Mark);
+    STKO_LINK(Mark) = MStack;
+    MStack = Mark;
+    Mark = temp;
+    JUMP_MARK;
+    }
+    FUNEND;
+}
+\end{code}
+
+Now the ``in'' code for \tr{STKO} closures.  First the A stack is flushed,
+then we chain down the update frames in the B stack, marking the update
+nodes.  When all have been marked we pop the stack and return.
+
+\begin{code}
+STGFUN(_PRIn_StkO)
+{
+    BitWord oldpos, newpos;
+    P_ mstack;
+    I_ size;
+
+    FUNBEGIN;
+
+    size = STKO_CLOSURE_SIZE(MStack);
+    GET_GEN_MARKED_PTRS(oldpos, MStack, size);
+
+    if (oldpos > STKO_CLOSURE_CTS_SIZE(MStack)) {
+    	/* Update the link, saving the old mstack */
+        mstack = STKO_LINK(MStack);
+	STKO_LINK(MStack) = Mark;
+    } else {
+    	/* Update the pointer, saving the old mstack */
+        mstack = (P_) STKO_CLOSURE_PTR(MStack, oldpos);
+	STKO_CLOSURE_PTR(MStack, oldpos) = (W_) Mark;
+    }
+
+    /* Calculate the next position to mark */
+    if (oldpos > STKO_SpA_OFFSET(MStack)) {
+    	/* Just walk backwards down the A stack */
+    	newpos = oldpos - 1;
+	SET_GEN_MARKED_PTRS(MStack,size,newpos);
+    	Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos);
+    	STKO_CLOSURE_PTR(MStack, newpos) = (W_) mstack;
+    	DEBUG_PRIN("STKA", oldpos);
+    	JUMP_MARK;
+    } else if (oldpos <= STKO_SuB_OFFSET(MStack)) {
+    	/* We're looking at an updatee in the B stack; find the next SuB up the chain */
+    	P_ subptr;
+
+	subptr = GRAB_SuB(STKO_CLOSURE_ADDR(MStack, oldpos - BREL(UF_UPDATEE)));
+	newpos = STKO_CLOSURE_OFFSET(MStack,subptr);
+    } else {
+    	/* Just fell off the end of the A stack; grab the first SuB */
+    	newpos = STKO_SuB_OFFSET(MStack);
+    }
+
+    if (newpos == 0) {	/* Grrr...  newpos is 1-based */
+    	/* Restore MStack and return */
+        SET_GEN_MARKED_PTRS(MStack,size,0L);
+    	DEBUG_PRLAST("STKO", oldpos);
+    	Mark = MStack;
+	MStack = mstack;
+        JUMP_MARK_RETURN;
+    }
+
+    /* newpos is actually the SuB; we want the corresponding updatee */
+    SET_GEN_MARKED_PTRS(MStack,size,newpos + BREL(UF_UPDATEE));
+    Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE));
+    STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)) = (W_) mstack;
+    DEBUG_PRIN("STKB", oldpos);
+    JUMP_MARK;
+
+    FUNEND;
+}
+#endif	/* CONCURRENT */
+\end{code}
+
+%****************************************************************************
+%
+\subsubsection[mark-caf]{Marking CAFs}
+%
+%****************************************************************************
+
+A CAF is shorted out as if it is an indirection.
+The CAF reference is explicitly updated by the garbage collector.
+
+\begin{code}
+STGFUN(_PRStart_Caf)
+{
+    FUNBEGIN;
+    DEBUG_PR_CAF;
+    Mark = (P_) IND_CLOSURE_PTR(Mark);
+    JUMP_MARK;
+    FUNEND;
+}
+
+#if 0 /* Code to avoid explicit updating of CAF references */
+      /* We need auxiliary mark and update reference info table */
+
+CAF_MARK_UPD_ITBL(Caf_Mark_Upd_info,const);
+
+/* Start marking a CAF -- special mark upd info table */
+/* Change to marking state and mark reference */
+
+STGFUN(_PRStart_Caf) 
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+	DEBUG_PR_MARKED;
+	JUMP_MARK_RETURN;
+    } else {
+	INIT_MARK_NODE("CAF ",1);
+    INIT_MSTACK(IND_CLOSURE_PTR2);
+    }
+    FUNEND;
+}
+
+/* Completed marking a CAF -- special mark upd info table */
+/* Change info table back to normal CAF info, return reference (Mark) */
+
+STGFUN(_PRInLast_Caf) 
+{
+    P_ temp;
+
+    FUNBEGIN;
+    DEBUG_PRLAST_CAF;
+    SET_INFO_PTR(MStack, Caf_info); /* normal marked CAF */
+
+    /* Like POP_MSTACK */
+    temp = MStack;
+    MStack = (P_) IND_CLOSURE_PTR(temp);
+    IND_CLOSURE_PTR(temp) = (W_) Mark;
+
+    /* Mark left unmodified so CAF reference is returned */
+    JUMP_MARK_RETURN;
+    FUNEND;
+}
+
+/* Marking a CAF currently being marked -- special mark upd info table */
+/* Just return CAF as if marked -- wont be shorted out */
+/* Marking once reference marked and updated -- normal CAF info table */
+/* Return reference to short CAF out */
+
+STGFUN(_PRStart_Caf) 
+{
+    FUNBEGIN;
+    if (IS_MARK_BIT_SET(Mark)) {
+        DEBUG_PR_MARKING_CAF;
+	JUMP_MARK_RETURN;
+    } else {
+    DEBUG_PR_MARKED_CAF;
+    Mark = (P_) IND_CLOSURE_PTR(Mark);
+    JUMP_MARK_RETURN;
+    }
+    FUNEND;
+}
+
+#define DEBUG_PR_MARKED_CAF \
+    if (SM_trace & 8)   \
+        fprintf(stderr, "PRMark CAF (Marked): 0x%lx -> 0x%lx, info 0x%lx\n", \
+		Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
+
+#define DEBUG_PR_MARKING_CAF \
+    if (SM_trace & 8)   \
+        fprintf(stderr, "PRMark CAF (Marking): 0x%lx -> 0x%lx, info 0x%lx\n", \
+		Mark, Mark, INFO_PTR(Mark))
+
+#define DEBUG_PRLAST_CAF \
+    if (SM_trace & 8)    \
+        fprintf(stderr, "PRRet  Last  (CAF ): 0x%lx -> 0x%lx, info 0x%lx -> 0x%lx ptrs 1\n", \
+                MStack, Mark, INFO_PTR(MStack), Caf_info)
+
+#endif /* 0 */
+
+\end{code}
+
+%****************************************************************************
+%
+\subsection[mark-root]{Root Marking Code}
+%
+%****************************************************************************
+
+Used by \tr{SMmarking.lc} -- but needs to be in \tr{.lhc} file.
+
+These are routines placed in closures at the bottom of the marking stack
+
+\begin{code}
+STGFUN(_Dummy_PRReturn_entry)
+{
+    FUNBEGIN;
+    fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n");
+    abort();
+    return(0);    /* won't happen; quiets compiler warnings */
+    FUNEND;
+}
+
+EXTFUN(_PRMarking_MarkNextRoot);
+EXTFUN(_PRMarking_MarkNextCAF);
+
+#ifdef CONCURRENT
+EXTFUN(_PRMarking_MarkNextSpark);
+#endif
+
+#ifdef PAR
+EXTFUN(_PRMarking_MarkNextGA);
+#else
+EXTFUN(_PRMarking_MarkNextAStack);
+EXTFUN(_PRMarking_MarkNextBStack);
+#endif /* not parallel */
+
+CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN")
+    /* just one, shared */
+
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure,
+		       _PRMarking_MarkNextRoot_info,
+		       _PRMarking_MarkNextRoot,
+		       _Dummy_PRReturn_entry);
+
+#ifdef CONCURRENT
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure,
+		       _PRMarking_MarkNextSpark_info,
+		       _PRMarking_MarkNextSpark,
+		       _Dummy_PRReturn_entry);
+#endif
+
+#ifdef PAR
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
+		       _PRMarking_MarkNextGA_info,
+		       _PRMarking_MarkNextGA,
+		       _Dummy_PRReturn_entry);
+#else
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
+		       _PRMarking_MarkNextAStack_info,
+		       _PRMarking_MarkNextAStack,
+		       _Dummy_PRReturn_entry);
+
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure,
+		       _PRMarking_MarkNextBStack_info,
+		       _PRMarking_MarkNextBStack,
+		       _Dummy_PRReturn_entry);
+
+#endif /* PAR */
+
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
+		       _PRMarking_MarkNextCAF_info,
+		       _PRMarking_MarkNextCAF,
+		       _Dummy_PRReturn_entry);
+
+STGFUN(_PRMarking_MarkNextRoot)
+{
+    extern P_ sm_roots_end;	/* &roots[rootno] -- one beyond the end */
+
+    FUNBEGIN;
+    /* Update root -- may have short circuited Ind */
+    *MRoot = (W_) Mark;
+
+    /* Is the next off the end */
+    if (++MRoot >= sm_roots_end)
+	RESUME_(miniInterpretEnd);
+
+    Mark = (P_) *MRoot;
+    JUMP_MARK;
+    FUNEND;
+}
+
+#ifdef CONCURRENT
+STGFUN(_PRMarking_MarkNextSpark)
+{
+    extern P_ sm_roots_end;	/* PendingSparksTl[pool] */
+
+    FUNBEGIN;
+    /* Update root -- may have short circuited Ind */
+    *MRoot = (W_) Mark;
+
+    /* Is the next off the end */
+    if (++MRoot >= sm_roots_end)
+	RESUME_(miniInterpretEnd);
+
+    Mark = (P_) *MRoot;
+    JUMP_MARK;
+    FUNEND;
+}
+#endif
+
+#ifdef PAR
+STGFUN(_PRMarking_MarkNextGA)
+{
+    FUNBEGIN;
+    /* Update root -- may have short circuited Ind */
+    ((GALA *)MRoot)->la = Mark;
+
+    do {
+	MRoot = (P_) ((GALA *) MRoot)->next;
+    } while (MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT);
+
+    /* Is the next off the end */
+    if (MRoot == NULL)
+	RESUME_(miniInterpretEnd);
+
+    Mark = ((GALA *)MRoot)->la;
+    JUMP_MARK;
+    FUNEND;
+}
+
+#else
+
+STGFUN(_PRMarking_MarkNextAStack)
+{
+    FUNBEGIN;
+    /* Update root -- may have short circuited Ind */
+    *MRoot = (W_) Mark;
+
+    /* Is the next off the end */
+    if (SUBTRACT_A_STK( (PP_) ++MRoot, stackInfo.botA) < 0)
+	RESUME_(miniInterpretEnd);
+
+    Mark = (P_) *MRoot;
+    JUMP_MARK;
+    FUNEND;
+}
+
+
+STGFUN(_PRMarking_MarkNextBStack)
+{
+    FUNBEGIN;
+    /* Update root -- may have short circuited Ind */
+    PUSH_UPDATEE(MRoot, Mark);
+
+    MRoot = GRAB_SuB(MRoot);
+
+    /* Is the next off the end */
+    if (SUBTRACT_B_STK(MRoot, stackInfo.botB) < 0)
+	RESUME_(miniInterpretEnd);
+
+    Mark = GRAB_UPDATEE(MRoot);
+    JUMP_MARK;
+    FUNEND;
+}
+#endif	/* PAR */
+\end{code}
+
+Mark the next CAF in the CAF list.
+
+\begin{code}
+STGFUN(_PRMarking_MarkNextCAF)
+{
+    FUNBEGIN;
+    /* Update root -- may have short circuted Ind */
+    IND_CLOSURE_PTR(MRoot) = (W_) Mark;
+
+    MRoot = (P_) IND_CLOSURE_LINK(MRoot);
+
+    /* Is the next CAF the end of the list */
+    if (MRoot == 0)
+	RESUME_(miniInterpretEnd);
+
+    Mark = (P_) IND_CLOSURE_PTR(MRoot);
+    JUMP_MARK;
+    FUNEND;
+}
+\end{code}
+
+\begin{code}
+#if 0 /* Code to avoid explicit updating of CAF references */
+
+STGFUN(_PRMarking_MarkNextCAF)
+{
+    FUNBEGIN;
+    MRoot = (P_) IND_CLOSURE_LINK(MRoot);
+
+    /* Is the next CAF the end of the list */
+    if (MRoot == 0)
+	RESUME_(miniInterpretEnd);
+
+    Mark = MRoot;
+    JUMP_MARK;
+    FUNEND;
+}
+#endif /* 0 */
+\end{code}
+
+Multi-slurp protection.
+
+\begin{code}
+#endif /* _INFO_MARKING */
+\end{code}
diff --git a/ghc/runtime/storage/SMmarkDefs.lh b/ghc/runtime/storage/SMmarkDefs.lh
new file mode 100644
index 0000000000..fccce1aaa2
--- /dev/null
+++ b/ghc/runtime/storage/SMmarkDefs.lh
@@ -0,0 +1,322 @@
+%****************************************************************************
+% 
+\section[SMmarkDefs.lh]{Definitions used by Pointer-Reversing Mark code}
+% 
+% (c) P. Sansom, K. Hammond, Glasgow University, January 26th 1993.  
+%
+%****************************************************************************
+
+Describe how to set the mark bit for a closure.
+
+\begin{code}
+#if defined(GCgn)
+
+#define SET_MARK_BIT(closure) 					\
+    do {							\
+      if (closure <= HeapLim) /* tested heap range for GCgn */	\
+	{							\
+	  long _hp_word = ((P_)closure) - HeapBase; 	    	\
+	  ASSERT(!IS_STATIC(INFO_PTR(closure)));		\
+	  DEBUG_SET_MARK(closure, _hp_word); 			\
+	  BitArray[_hp_word / BITS_IN(BitWord)] |= 	    	\
+    	    	1L << (_hp_word & (BITS_IN(BitWord) - 1));    	\
+        }							\
+    } while(0)
+
+#define CLEAR_MARK_BIT(closure)					\
+    do {							\
+	long _hp_word = ((P_)closure) - HeapBase; 		\
+	ASSERT(!IS_STATIC(INFO_PTR(closure)));			\
+	BitArray[_hp_word / BITS_IN(BitWord)] &= 	    	\
+    	    	~(1L << (_hp_word & (BITS_IN(BitWord) - 1)));  	\
+    } while (0)
+
+#else
+
+#define SET_MARK_BIT(closure) 					\
+    do {							\
+	long _hp_word = ((P_)closure) - HeapBase; 		\
+	ASSERT(!IS_STATIC(INFO_PTR(closure)));			\
+	DEBUG_SET_MARK(closure, _hp_word); 			\
+	BitArray[_hp_word / BITS_IN(BitWord)] |= 	    	\
+    	    	1L << (_hp_word & (BITS_IN(BitWord) - 1));    	\
+    } while (0)
+
+#define CLEAR_MARK_BIT(closure)					\
+    do {							\
+	long _hp_word = ((P_)closure) - HeapBase; 		\
+	ASSERT(!IS_STATIC(INFO_PTR(closure)));			\
+	BitArray[_hp_word / BITS_IN(BitWord)] &= 	    	\
+    	    	~(1L << (_hp_word & (BITS_IN(BitWord) - 1)));  	\
+    } while (0)
+
+\end{code}
+
+Macros from hell for frobbing bits in the bit array while marking.  We
+maintain a counter after the mark bit that tells us which pointers
+we've visited in a closure.  The bits in this counter may span word
+boundaries, and require some considerable ickiness to get munged into
+one word so Mr C Programmer can use them.
+
+Three variants follow.  The first is for closures which contain fewer
+pointers than there are bits in a word.
+
+\begin{code}
+
+#define GM_MASK(x) ((1L << (x)) - 1)
+
+#define GET_MARKED_PTRS(dest,closure,ptrs)			\
+    do {							\
+	long hw = ((P_)(closure)) - HeapBase + 1;		\
+	BitWord *bw = BitArray + (hw / BITS_IN(BitWord));	\
+	int offset = hw & (BITS_IN(BitWord) - 1);	    	\
+	int bat = BITS_IN(BitWord) - offset;			\
+								\
+	ASSERT(!IS_STATIC(INFO_PTR(closure)));			\
+								\
+	(dest) = (ptrs) <= bat ?				\
+	    bw[0] >> offset & GM_MASK(ptrs) :		    	\
+	    bw[0] >> offset | 	    	    	    	    	\
+                (bw[1] & GM_MASK((ptrs) - bat)) << bat;	    	\
+    } while (0)
+
+/* hw is the offset in words of closure from HeapBase + 1.
+
+   bw points to the BitArray word containing the bit corresponding
+	to the *second* word of the closure [hence +1 above]
+	(the bit corresp first word is the mark bit)
+
+   offset is the offset (in bits, from LS end, zero indexed) within *bw
+	of the first bit of value in *bw, 
+
+   bat is offset from the other end of the word; that's the same
+	as the number of bits available to store value in *bw.
+
+
+NOTA BENE: this code is awfully conservative.  In order to store a
+value which ranges 0--ptrs we use a field of ptrs bits wide.  We
+only need a field of log(ptrs) wide!
+
+*/
+
+/* "ptrs" is actually used as the width of the bit-field
+   in which we store "val". */
+
+#define SET_MARKED_PTRS(closure,ptrs,val)		    	\
+    do {						    	\
+	long hw = ((P_)(closure)) - HeapBase + 1;	    	\
+	BitWord *bw = BitArray + (hw / BITS_IN(BitWord));	\
+	int offset = hw & (BITS_IN(BitWord) - 1);    	    	\
+	int bat = BITS_IN(BitWord) - offset;		    	\
+    	BitWord bits;					    	\
+    	    	    	    	    	    	    	    	\
+	ASSERT( (ptrs) < BITS_IN(BitWord) );			\
+	ASSERT(!IS_STATIC(INFO_PTR(closure)));			\
+							    	\
+        bits = bw[0] & ~(GM_MASK(ptrs) << offset); 	    	\
+        bw[0] = bits | (val) << offset;    	    	    	\
+	if ((ptrs) > bat) {				    	\
+    	    bits = bw[1] & ~GM_MASK((ptrs) - bat);	    	\
+	    bw[1] = bits | ((val) >> bat);  		    	\
+	}						    	\
+    } while (0)
+/* NB Since ptrs < BITS_IN(BitWord)
+   we can be sure that the conditional will only happen if bat is strictly
+   *smaller* than BITS_IN(BitWord), and hence the right shift in the
+   last line is ok */
+
+/* 
+ * These are for the GEN family, which may blow up the GM_MASK macro.
+ */
+
+	/* If there are more ptrs than bits in a word, we still
+	   use just one word to store the value; value is bound to
+	   be < 2**(bits-in-word - 1) */
+
+#define __MIN__(a,b) (((a) < (b)) ? (a) : (b))
+
+#define GET_GEN_MARKED_PTRS(dest,closure,ptrs)			\
+	GET_MARKED_PTRS(dest,closure,__MIN__(ptrs,BITS_IN(BitWord)-1))
+
+#define SET_GEN_MARKED_PTRS(closure,ptrs,val)		    	\
+	SET_MARKED_PTRS(closure,__MIN__(ptrs,BITS_IN(BitWord)-1),val)
+
+/* Be very careful to use the following macro only for dynamic closures! */
+
+#define IS_MARK_BIT_SET(closure)				  		\
+	((BitArray[(((P_)closure) - HeapBase) / BITS_IN(BitWord)] >>		\
+	 ((((P_)closure) - HeapBase) & (BITS_IN(BitWord) - 1))) & 0x1)
+
+#endif
+\end{code}
+
+Don't set the mark bit when changing to marking in the next pointer.
+
+\begin{code}
+#define	INIT_MARK_NODE(dbg,ptrs)		\
+        do {					\
+	  DEBUG_PRSTART(dbg, ptrs);		\
+          LINK_GLOBALADDRESS(Mark);    	    	\
+	  SET_MARK_BIT(Mark);			\
+        } while (0)
+
+#define	CONTINUE_MARKING_NODE(dbg,pos)				\
+        do {							\
+	  DEBUG_PRIN(dbg, pos);			\
+        } while (0)
+\end{code}
+
+@JUMP_MARK@ and @JUMP_MARK_RETURN@ define how to jump to the marking
+entry code for a child closure (\tr{Mark}), or to the return code for
+its parent (\tr{MStack}), when marking's been completed.
+
+\begin{code}
+#define	JUMP_MARK						\
+	JMP_(PRMARK_CODE(INFO_PTR(Mark)))
+
+#define	JUMP_MARK_RETURN					\
+	JMP_(PRRETURN_CODE(INFO_PTR(MStack)))
+\end{code}
+
+Initialise the marking stack to mark from the first pointer in the
+closure (as specified by \tr{first_ptr}).  The type of the closure is
+given by \tr{closure_ptr}.
+
+\begin{code}
+#define	INIT_MSTACK_FROM(closure_ptr,first_ptr)			\
+    do { 							\
+	P_ temp = (P_) closure_ptr(Mark, first_ptr);	    	\
+    	closure_ptr(Mark, first_ptr) = (W_) MStack;   	    	\
+/*fprintf(stderr,"first_ptr=%d;temp=%lx;Mark=%lx;MStack=%lx\n",first_ptr,temp,Mark,MStack);*/ \
+    	MStack = Mark;                                  	\
+    	Mark = temp;                                  		\
+        JUMP_MARK;						\
+    } while (0)
+\end{code}
+
+Initialise the marking stack to mark from the first pointer in
+the closure.  The type of the closure is given by \tr{closure_ptr}.
+
+\begin{code}
+#define	INIT_MSTACK(closure_ptr)				\
+    INIT_MSTACK_FROM(closure_ptr,1)
+\end{code}
+
+Move to the next pointer after \tr{pos} in the closure whose
+type is given by \tr{closure_ptr}.
+
+\begin{code}
+#define	MOVE_TO_NEXT_PTR(closure_ptr,pos)			\
+    do {							\
+	P_ temp = (P_) closure_ptr(MStack, pos+1); 	    	\
+	closure_ptr(MStack, pos+1) = closure_ptr(MStack, pos); 	\
+	closure_ptr(MStack, pos) = (W_) Mark;   		\
+	Mark = temp;						\
+        JUMP_MARK;						\
+    } while(0)
+\end{code}
+
+Pop the mark stack at \tr{pos}, having flushed all pointers in
+a closure.
+
+\begin{code}
+#define	POP_MSTACK(dbg,closure_ptr,pos)				\
+    do {							\
+	RESTORE_MSTACK(dbg,closure_ptr,pos);			\
+        JUMP_MARK_RETURN;					\
+    } while (0)
+
+#define	RESTORE_MSTACK(dbg,closure_ptr,pos)			\
+    do {							\
+	P_ temp = Mark;                                  	\
+        DEBUG_PRLAST(dbg, pos);	                   		\
+	Mark = MStack;                                     	\
+	MStack = (P_) closure_ptr(Mark, pos);		    	\
+    	closure_ptr(Mark, pos) = (W_) temp;	  	    	\
+    } while (0)
+\end{code}
+
+Define some debugging macros.
+
+\begin{code}
+#if defined(_GC_DEBUG)
+
+#define DEBUG_PRSTART(type, ptrsvar) \
+    if (SM_trace & 8)                         \
+        fprintf(stderr, "PRMark Start (%s): 0x%lx, info 0x%lx ptrs %ld\n", \
+                type, Mark, INFO_PTR(Mark), ptrsvar)
+
+#define DEBUG_PRIN(type, posvar) \
+    if (SM_trace & 8)                     \
+        fprintf(stderr, "PRRet  In    (%s): 0x%lx, info 0x%lx pos %ld\n", \
+                type, MStack, INFO_PTR(MStack), posvar)
+
+#define DEBUG_PRLAST(type, ptrvar) \
+    if (SM_trace & 8)                       \
+        fprintf(stderr, "PRRet  Last  (%s): 0x%lx, info 0x%lx ptrs %ld\n", \
+                type, MStack, INFO_PTR(MStack), ptrvar)
+
+#define DEBUG_PR_MARKED \
+    if (SM_trace & 8)   \
+        fprintf(stderr, "PRMark Marked      : 0x%lx, info 0x%lx\n", \
+		Mark, INFO_PTR(Mark))
+
+#define DEBUG_PR_STAT \
+    if (SM_trace & 8) \
+        fprintf(stderr, "PRMark Static      : 0x%lx, info 0x%lx\n", \
+		Mark, INFO_PTR(Mark))
+
+#define DEBUG_PR_IND  \
+    if (SM_trace & 8) \
+        fprintf(stderr, "PRMark Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
+		Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
+
+#define DEBUG_PR_CAF  \
+    if (SM_trace & 8) \
+        fprintf(stderr, "PRMark Caf : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
+		Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
+
+#define DEBUG_PR_CONST \
+    if (SM_trace & 8)  \
+        fprintf(stderr, "PRMark Const : 0x%lx -> 0x%lx, info 0x%lx\n", \
+		Mark, CONST_STATIC_CLOSURE(INFO_PTR(Mark)), INFO_PTR(Mark))
+
+#define DEBUG_PR_CHARLIKE \
+    if (SM_trace & 8)  \
+        fprintf(stderr, "PRMark CharLike (%lx) : 0x%lx -> 0x%lx, info 0x%lx\n", \
+		CHARLIKE_VALUE(Mark), Mark, CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark)), INFO_PTR(Mark))
+
+#define	DEBUG_PR_INTLIKE_TO_STATIC \
+    if (SM_trace & 8)  \
+        fprintf(stderr, "PRMark IntLike to Static (%ld) : 0x%lx -> 0x%lx, info 0x%lx\n", \
+		INTLIKE_VALUE(Mark), Mark, INTLIKE_CLOSURE(INTLIKE_VALUE(Mark)), INFO_PTR(Mark))
+
+#define	DEBUG_PR_INTLIKE_IN_HEAP \
+    if (SM_trace & 8)  \
+        fprintf(stderr, "PRMark IntLike in Heap   (%ld) : 0x%lx, info 0x%lx\n", \
+		INTLIKE_VALUE(Mark), Mark, INFO_PTR(Mark))
+
+#define DEBUG_PR_OLDIND \
+    if (SM_trace & 8) \
+        fprintf(stderr, "PRMark OldRoot Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
+		Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
+
+#else
+
+#define DEBUG_PRSTART(type, ptrvar)
+#define DEBUG_PRIN(type, posvar)
+#define DEBUG_PRLAST(type, ptrvar)
+#define DEBUG_PR_MARKED
+#define DEBUG_PR_STAT
+#define DEBUG_PR_IND
+#define DEBUG_PR_CAF
+#define DEBUG_PR_CONST
+#define DEBUG_PR_CHARLIKE
+#define	DEBUG_PR_INTLIKE_TO_STATIC
+#define	DEBUG_PR_INTLIKE_IN_HEAP
+#define DEBUG_PR_OLDIND
+
+#endif
+
+\end{code}
+
diff --git a/ghc/runtime/storage/SMmarking.lc b/ghc/runtime/storage/SMmarking.lc
new file mode 100644
index 0000000000..33d366ea68
--- /dev/null
+++ b/ghc/runtime/storage/SMmarking.lc
@@ -0,0 +1,267 @@
+/*************************************************************************
+                           MARKING OF ROOTS
+*************************************************************************/
+
+[Something needed here to explain what this is doing.  KH]
+
+\begin{code}
+
+#define MARK_REG_MAP
+#include "SMinternal.h"
+
+extern I_ doSanityChks; /* ToDo: move tidily */
+
+#if defined(_INFO_MARKING)
+
+#if defined (__STG_GCC_REGS__) /* If we are using registers load _SAVE */
+
+/* If we are using registers load _SAVE */
+#define Mark     SAVE_Mark
+#define MRoot    SAVE_MRoot
+#define MStack   SAVE_MStack
+#define BitArray SAVE_BitArray
+#define HeapBase SAVE_HeapBase
+#define HeapLim  SAVE_HeapLim
+
+#endif /* registerized */
+
+/* These in SMmark.lhc -- need to be in .hc file */
+EXTFUN(_startMarkWorld);
+
+EXTFUN(_PRMarking_MarkNextRoot);
+EXTFUN(_PRMarking_MarkNextCAF);
+EXTDATA(_PRMarking_MarkNextRoot_closure);
+EXTDATA(_PRMarking_MarkNextCAF_closure);
+
+#ifdef CONCURRENT
+EXTFUN(_PRMarking_MarkNextSpark);
+EXTDATA(_PRMarking_MarkNextSpark_closure);
+#endif
+
+#ifdef PAR
+EXTFUN(_PRMarking_MarkNextGA);
+EXTDATA(_PRMarking_MarkNextGA_closure);
+#else
+EXTFUN(_PRMarking_MarkNextAStack);
+EXTFUN(_PRMarking_MarkNextBStack);
+EXTDATA(_PRMarking_MarkNextAStack_closure);
+EXTDATA(_PRMarking_MarkNextBStack_closure);
+#endif /* not parallel */
+
+P_ sm_roots_end;
+
+I_
+markHeapRoots(sm, cafs1, cafs2, base, lim, bit_array)
+    smInfo *sm;
+    P_ cafs1, cafs2;  /* Pointer to CAF lists */
+    P_ base;          /* Heap closure in range only tested for by GCgn */
+    P_ lim;
+    BitWord *bit_array;
+{
+#ifdef CONCURRENT
+    int pool;
+#endif
+
+#if 0 /* Code to avoid explicit updating of CAF references */
+
+    /* Before marking have to modify CAFs to auxillary info table */
+    P_ CAFptr;
+    DEBUG_STRING("Setting Mark & Upd CAFs:");
+    for (CAFptr = cafs1; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+	INFO_PTR(CAFptr) = (W_) Caf_Mark_Upd_info;
+    }
+    for (CAFptr = cafs2; CAFptr;
+	 CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
+	INFO_PTR(CAFptr) = (W_) Caf_Mark_Upd_info;
+    }
+    DEBUG_STRING("Marking CAFs:");
+    if (cafs1) {
+	MRoot = (P_) cafs1;
+	Mark = (P_) MRoot;
+	MStack = (P_) _PRMarking_MarkNextCAF_closure;
+	/*ToDo: debugify */
+	miniInterpret((StgFunPtr)_startMarkWorld);
+    }
+    if (cafs2) {
+	MRoot = (P_) cafs2;
+	Mark = (P_) MRoot;
+	MStack = (P_) _PRMarking_MarkNextCAF_closure;
+	/*ToDo: debugify */
+	miniInterpret((StgFunPtr)_startMarkWorld);
+    }
+
+#endif /* 0 */
+
+    BitArray = bit_array;
+    HeapBase = base;
+    HeapLim = lim;
+
+    DEBUG_STRING("Marking Roots:");
+    if (sm->rootno > 0) {
+	sm_roots_end = (P_) &sm->roots[sm->rootno];
+	MRoot = (P_) sm->roots;
+	Mark = (P_) *MRoot;
+	MStack = (P_) _PRMarking_MarkNextRoot_closure;
+#if defined(__STG_TAILJUMPS__)
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#else
+    if (doSanityChks)
+	miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
+    else
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#endif /* ! tail-jumping */
+    }
+
+#ifdef CONCURRENT
+    for(pool = 0; pool < SPARK_POOLS; pool++) {
+	if (PendingSparksHd[pool] < PendingSparksTl[pool]) {
+	    sm_roots_end = (P_) PendingSparksTl[pool];
+	    MRoot = (P_) PendingSparksHd[pool];
+	    Mark = (P_) *MRoot;
+	    MStack = (P_) _PRMarking_MarkNextSpark_closure;
+#if defined(__STG_TAILJUMPS__)
+	    miniInterpret((StgFunPtr)_startMarkWorld);
+#else
+	if (doSanityChks)
+	    miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
+	else
+	    miniInterpret((StgFunPtr)_startMarkWorld);
+#endif /* ! tail-jumping */
+        }
+    }
+#endif
+
+#ifdef PAR
+    DEBUG_STRING("Marking GA Roots:");
+    MRoot = (P_) liveIndirections;
+    while(MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT)
+	MRoot = (P_) ((GALA *)MRoot)->next;
+    if (MRoot != NULL) {
+	Mark = ((GALA *)MRoot)->la;
+	MStack = (P_) _PRMarking_MarkNextGA_closure;
+#if defined(__STG_TAILJUMPS__)
+	miniInterpret((StgFunPtr) _startMarkWorld);
+#else
+	if (doSanityChks)
+	    miniInterpret_debug((StgFunPtr) _startMarkWorld, NULL);
+	else
+	    miniInterpret((StgFunPtr) _startMarkWorld);
+#endif /* ! tail-jumping */
+    }
+#else
+    /* Note: no *external* stacks in parallel world */
+    DEBUG_STRING("Marking A Stack:");
+    if (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) >= 0) {
+	MRoot = (P_) MAIN_SpA;
+	Mark = (P_) *MRoot;
+	MStack = (P_) _PRMarking_MarkNextAStack_closure;
+#if defined(__STG_TAILJUMPS__)
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#else
+    if (doSanityChks)
+	miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
+    else
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#endif /* ! tail-jumping */
+    }
+
+    DEBUG_STRING("Marking B Stack:");
+    if (SUBTRACT_B_STK(MAIN_SuB, stackInfo.botB) > 0) {
+	MRoot = MAIN_SuB;
+	Mark = GRAB_UPDATEE(MRoot);
+	MStack = (P_) _PRMarking_MarkNextBStack_closure;
+	miniInterpret((StgFunPtr)_startMarkWorld);
+    }
+#endif /* PAR */
+
+    DEBUG_STRING("Marking & Updating CAFs:");
+    if (cafs1) {
+	MRoot = cafs1;
+	Mark = (P_) IND_CLOSURE_PTR(MRoot);
+	MStack = (P_) _PRMarking_MarkNextCAF_closure;
+#if defined(__STG_TAILJUMPS__)
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#else
+    if (doSanityChks)
+	miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
+    else
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#endif /* ! tail-jumping */
+    }
+
+    if (cafs2) {
+	MRoot = cafs2;
+	Mark = (P_) IND_CLOSURE_PTR(MRoot);
+	MStack = (P_) _PRMarking_MarkNextCAF_closure;
+#if defined(__STG_TAILJUMPS__)
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#else
+    if (doSanityChks)
+	miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
+    else
+	miniInterpret((StgFunPtr)_startMarkWorld);
+#endif /* ! tail-jumping */
+    }
+    return 0;
+}
+
+#endif /* _INFO_MARKING */
+
+\end{code}
+
+
+CODE REQUIRED (expressed as a loop):
+
+MARK ROOTS
+
+    MStack = _PRMarking_MarkNextRoot_closure;
+    for (MRoot = (P_) sm->roots;
+         MRoot < (P_) &sm->roots[sm->rootno];
+	 MRoot++) {
+	Mark = (P_) *MRoot;
+	(PRMARK_CODE(INFO_PTR(Mark)))();
+_PRMarking_MarkNextRoot:
+	*MRoot = (W_) Mark;
+    }
+
+
+MARK AStack
+
+    MStack = _PRMarking_MarkNextAStack_closure;
+    for (MRoot = MAIN_SpA;
+	 SUBTRACT_A_STK(MRoot, stackInfo.botA) >= 0;
+	 MRoot = MRoot + AREL(1)) {
+	Mark = (P_) *MRoot;
+	(PRMARK_CODE(INFO_PTR(Mark)))();
+_PRMarking_MarkNextAStack:
+	*MRoot = (W_) Mark;
+    }
+
+
+MARK BStack
+
+    MStack = _PRMarking_MarkNextBStack_closure;
+    for (MRoot = MAIN_SuB;  --- Topmost Update Frame
+	 SUBTRACT_B_STK(MRoot, stackInfo.botB) > 0;
+	 MRoot = GRAB_SuB(MRoot)) {
+
+	Mark = GRAB_UPDATEE(MRoot);
+	(PRMARK_CODE(INFO_PTR(Mark)))();
+_PRMarking_MarkNextBStack:
+	PUSH_UPDATEE(MRoot, Mark);
+    }
+
+
+MARK CAFs
+
+    MStack = _PRMarking_MarkNextCAF_closure;
+    for (MRoot = sm->CAFlist;
+	 MRoot;
+	 MRoot = (P_) IND_CLOSURE_LINK(MRoot))
+
+	Mark = IND_CLOSURE_PTR(MRoot);
+	(PRMARK_CODE(INFO_PTR(Mark)))();
+_PRMarking_MarkNextCAF:
+	IND_CLOSURE_PTR(MRoot) = (W_) Mark;
+    }
diff --git a/ghc/runtime/storage/SMscan.lc b/ghc/runtime/storage/SMscan.lc
new file mode 100644
index 0000000000..35f1b056e6
--- /dev/null
+++ b/ghc/runtime/storage/SMscan.lc
@@ -0,0 +1,1695 @@
+/*************************************************************************
+                             SCANNING CODE
+
+This file contains the basic routines required for inplace compacting
+garbage collection. It is based on Jonkers's algorithm.
+
+There is a compacting routine as well as all the basic routines which
+are placed in the info tables of the appropriate closures.
+
+  ToDo: Remove Fillers -- Compiler
+	Remove Dummy Filler Macros -- SMupdate.lh
+        Remove special "shrinking" info_upd stuff -- Compiler
+	Remove special "shrinking" info_upd stuff -- SMinterface.lh
+
+	Updateable closure size can now be relaxed
+	  MinUpdSize is now 1
+	  May want to allocate larger closures to enable updates inplace
+	    eg  Int     1    MkInt etc fit
+	        List    2    Nil,List fit
+	        STree   3    Leaf(2) Branch(3) fit
+	        STree   2    Leaf(2) fits, Branch(3) fails
+		Tuple4  1    MkTuple4 fails
+
+	Need BHs of appropriate sizes (reserve BHed space for update)
+	For Appel will require BH_1 to grow to size 2 when collected.
+
+*************************************************************************/
+
+\begin{code}
+
+#define SCAN_REG_MAP
+#include "SMinternal.h"
+
+#if defined(_INFO_COMPACTING)
+
+/* Define appropriate global variables as potential register variables */
+/* Assume GC code saves and restores global registers used */
+
+RegisterTable ScanRegTable;
+
+#ifndef PAR
+/* As we perform compaction, those CHP's which are still alive get
+   added to this list. [ADR] */
+StgPtr NewMallocPtrList;
+#endif /* !PAR */
+
+P_
+Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words
+#ifndef PAR
+, MallocPtrList
+#endif
+)
+    P_  base;
+    P_  lim;
+    P_  scanbase;
+    P_  scanlim;
+    BitWord *bit_array;
+    I_  bit_array_words;
+#ifndef PAR
+    StgPtr *MallocPtrList;
+#endif
+{
+    BitWord *bit_array_ptr, *bit_array_end;
+    P_ scan_w_start, info; I_ size;
+
+    LinkLim = lim;  /* Only checked for generational collection */
+
+#if defined(GCgn)
+
+    /* Scan collected new gen semi-space linking pointers to old gen */
+    /* No closures to unlink (no new ptrs will be linked)            */
+    /* Have to reset closure to unmarked if it has been marked       */
+    /* If not marked, we will still link (and unlink) as we need to  */
+    /*   get the size to find next closure.                          */
+    /*   It will be collected next minor collection as no root exists*/
+
+    DEBUG_SCAN("Scan Link Area: Base", scanbase, "Lim", scanlim);
+
+    Scan = scanbase;
+    New  = 0; /* unused -- except by debugging message */
+
+    while (Scan < scanlim) {
+	info = (P_) UNMARK_LOCATION(INFO_PTR(Scan));
+	    Scan += (*SCAN_LINK_CODE(info))();
+	}
+#endif /* GCgn */
+
+    DEBUG_SCAN("Scan Link Bits: Base", base, "Bits", bit_array);
+
+    bit_array_ptr = bit_array;
+    bit_array_end = bit_array + bit_array_words;
+    scan_w_start = base;
+    New = base; /* used to unwind */
+
+#ifndef PAR
+    NewMallocPtrList = NULL; /* initialise new MallocPtrList */
+             /* As we move MallocPtrs over, we'll add them to this list. */
+#endif /* !PAR */
+
+    while (bit_array_ptr < bit_array_end) {
+	BitWord w = *(bit_array_ptr++);
+
+	Scan = scan_w_start;
+	while (w) {
+
+	    if (! (w & 0x1)) { /* bit not set */
+		Scan++;        /* look at next bit */
+		w >>= 1;
+
+	    } else { /* Bit Set -- Enter ScanLink for closure */
+		info = (P_) INFO_PTR(Scan);
+		while (MARKED_LOCATION(info)) {
+		    P_ next;
+		    info = UNMARK_LOCATION(info);
+		    next = (P_) *info;
+		    DEBUG_UNLINK_LOCATION(info, Scan, New);
+		    *info = (W_) New;
+		    info = next;
+		}
+		INFO_PTR(Scan) = (W_) info;
+/*
+if (SM_trace & 8) {
+    fprintf(stderr, "  Marked: word %ld, val 0x%lx, cur 0x%lx, Scan_w 0x%lx, Scan 0x%lx, Info 0x%lx, Code 0x%lx\n",
+	    (bit_array_ptr-1) - bit_array, *(bit_array_ptr-1), w, scan_w_start, Scan, info,
+	    SCAN_LINK_CODE(info)); };
+*/
+
+		size = (*SCAN_LINK_CODE(info))();
+
+		ASSERT( size >= 0 );
+		New  += size;  /* set New address of next closure */
+
+		Scan += size;  /* skip size bits */ 
+
+		if (size >= BITS_IN(BitWord)) break;
+		    /* NOTA BENE: if size >= # bits in BitWord, then the result
+			of this operation is undefined!  Hence the need for
+			this break! */
+		w >>= size;
+	    }
+	}
+	scan_w_start += BITS_IN(BitWord);
+    }
+    DEBUG_SCAN("Scan Link Bits: End", Scan, "New", New);
+
+    bit_array_ptr = bit_array;
+    bit_array_end = bit_array + bit_array_words;
+    scan_w_start  = base;	/* Points to the heap word corresponding to the
+				   first bit of *bit_array_ptr */
+
+    New = base; /* used to unwind and move */
+
+    DEBUG_SCAN("Scan Move Bits: Base", base, "Bits", bit_array);
+    while (bit_array_ptr < bit_array_end) {
+
+	/* Grab bit word and clear (its the last scan) */
+	/* Dont need to clear for Appel or Generational major collection */
+	/* Why not???  I think it's because they have a pass which zaps all
+	   the bit array to zero.  But why do they need it?  Or, why
+	   doesn't dual-mode need it? 
+
+	   It's probably easier just to *always* to zap at the beginning of
+	   GC, and remove this conditional compilation here.  */
+#if defined(GCap) || defined(GCgn)
+	BitWord w = (I_) *(bit_array_ptr++);
+#else
+	BitWord w = (I_) *bit_array_ptr;
+	*(bit_array_ptr++) = 0;
+#endif
+
+	Scan = scan_w_start;
+	while (w) {
+	    if (! (w & 0x1)) { /* bit not set */
+		Scan++;        /* look at next bit */
+		w >>= 1;
+
+	    } else {	/* Bit Set -- Enter ScanMove for closure*/
+/*HACK	if (SM_trace&8) {fprintf(stderr,"Scan=%x\n",Scan);} */
+		info = (P_) INFO_PTR(Scan);
+/*HACK	if (SM_trace&8) {fprintf(stderr,"info=%x\n",info);} */
+		while (MARKED_LOCATION(info)) {
+		    P_ next;
+		    info = UNMARK_LOCATION(info);
+                    next = (P_) *info;
+/*HACK	    if (SM_trace&8) {fprintf(stderr,"next=%x\n",next);} */
+		    DEBUG_UNLINK_LOCATION(info, Scan, New);
+/*HACK	    if (SM_trace&8) {fprintf(stderr,"New=%x\n",New);} */
+		    *info = (W_) New;
+		    info = next;
+/*HACK	    if (SM_trace&8) {fprintf(stderr,"*info=%x,info=%x\n",*info,info);} */
+		}
+/*HACK	if (SM_trace&8) {fprintf(stderr,"preNew info=%x\n",info);} */
+		INFO_PTR(New) = (W_) info;
+
+/*
+if (SM_trace & 8) {
+    fprintf(stderr, "  Marked: word %ld, cur 0x%lx, Scan_w 0x%lx, Scan 0x%lx, Info 0x%lx, Code 0x%lx\n",
+	    (bit_array_ptr-1) - bit_array, w, scan_w_start, Scan, info, SCAN_MOVE_CODE(info)); };
+*/
+
+		size = (*SCAN_MOVE_CODE(info))();
+		New  += size;  /* set New address of next closure */
+		Scan += size;  /* skip size bits */  
+
+		if (size >= BITS_IN(BitWord)) break;
+		    /* NOTA BENE: if size >= # bits in BitWord, then the result
+			of this operation is undefined!  Hence the need for
+			this break! */
+		w   >>= size;  /* NB: comment above about shifts */
+	    }
+	}
+
+	/* At this point we've exhausted one word of mark bits */
+	/* Make scan_w_start point to the heap word corresponding to the
+	   first bit of the next word of mark bits */
+	scan_w_start += BITS_IN(BitWord);
+    }
+    DEBUG_SCAN("Scan Link Bits: End", Scan, "New", New);
+
+#ifdef PAR
+    RebuildLAGAtable();
+#else
+    VALIDATE_MallocPtrList( NewMallocPtrList );
+    *MallocPtrList = NewMallocPtrList;
+#endif /* PAR */
+
+    return(New);
+}
+
+\end{code}
+
+/*************************************************************************
+                   Basic SCAN LINK and SCAN MOVE Routines
+
+First Scan on Closures
+  _ScanLink_S_N
+
+  Retrieved using SCAN_LINK_CODE(infoptr)  (for a true unmarked infoptr)
+
+Links the closure's ptr locations to the info pointer of the closure's
+they actually point. Returns the size of the closure so New can be updated
+to point to next closure. This also allows sequential scan (if there are no
+holes i.e. it has already been collected).
+
+Must first unwind the locations linked to this closure updating with
+the new location of this closure before entering the code. The code
+can only be access from the info pointer at the end of this location
+list, which must be restored before entering.
+
+  Calling Conventions (After unwinding and updating locations pointed to):
+    Scan  -- points to this closure
+    LinkLim -- points to end of heap are requiring pointer to be linked
+
+    New (optional) -- points to the new location that this closure will reside
+                      this is only required for meaningful debugging meassge
+
+Second Scan on Closures
+  _ScanMove_S
+
+  Retrieved using SCAN_MOVE_CODE(infoptr)  (for a true unmarked infoptr)
+ 
+Slides the closure down to its new location, New. Returns the size of
+the closure so New can be updated to point to the next closure.
+
+Must first unwind the locations linked to this closure updating with
+the new location of this closure before entering the code. The code
+can only be access from the info pointer at the end of this location
+list, which must be restored before entering.
+
+  Calling Conventions (After unwinding and updating locations pointed to):
+    Scan  -- points to this closure
+    New   -- points to the new location that this closure will reside
+
+
+Will have  MARKING  routines in info tables as well:
+
+Marking A Closure: 
+  _PRStart_N
+
+  Retrieved using PRMARK_CODE(infoptr)
+
+Returning To A Closure Being Marked:
+  _PRIn_I
+  _PRInLast_N
+
+  Retrieved using PRRETURN_CODE(infoptr)
+
+
+
+May have  COPYING  routines in info tables as well:
+
+Evacuation code:  _Evacuate_S
+Scavenging code:  _Scavenge_S_N
+
+    See GCscav.lhc GCevac.lc
+
+
+
+The following registers are used by the Compacting collection:
+
+New	-- The new address of a closure
+Scan    -- The current address of a closure
+LinkLim -- The limit of the heap requiring to be linked & moved
+
+**************************************************************************/
+
+\begin{code}
+
+#if defined(GCgn)
+#define LINK_LOCATION(i) LINK_LOCATION_TO_CLOSURE((Scan+(i)),LinkLim)
+#else /* ! GCgn */
+#define LINK_LOCATION(i) LINK_LOCATION_TO_CLOSURE(Scan+(i))
+#endif /* ! GCgn */
+
+/* Link location of nth pointer in SPEC/STKO closure (starting at 1) */
+#define SPEC_LINK_LOCATION(ptr) LINK_LOCATION((SPEC_HS-1) + (ptr))
+#define STKO_LINK_LOCATION(ptr) LINK_LOCATION((STKO_HS-1) + (ptr))
+
+
+/* Slide the ith word (starting at 0) */
+#define SLIDE_WORD(position)    New[position] = Scan[position]
+
+/* Slide the ith ptr (starting at 0), adjusting by offset */
+#define ADJUST_WORD(pos,off)    ((PP_)New)[pos] += (off)
+
+/* Slide the nth free var word in a SPEC closure (starting at 1) */
+#define SPEC_SLIDE_WORD(n)      SLIDE_WORD((SPEC_HS-1) + (n))
+
+#ifndef PAR
+/* Don't slide the MallocPtr list link - instead link moved object into
+   @NewMallocPtrList@ */
+
+#define MallocPtr_SLIDE_DATA \
+        MallocPtr_CLOSURE_DATA(New) = MallocPtr_CLOSURE_DATA(Scan)
+#define MallocPtr_RELINK				\
+{							\
+	MallocPtr_CLOSURE_LINK(New) = NewMallocPtrList;	\
+        NewMallocPtrList = New;	                        \
+}
+#endif /* !PAR */
+
+/* The SLIDE_FIXED_HDR macro is dependent on the No of FIXED_HS */
+
+#if FIXED_HS == 1
+#define SLIDE_FIXED_HDR         /* Already Assigned INFO_PTR */
+#else
+#if FIXED_HS == 2
+#define SLIDE_FIXED_HDR         SLIDE_WORD(1)
+#else
+#if FIXED_HS == 3
+#define SLIDE_FIXED_HDR         SLIDE_WORD(1);SLIDE_WORD(2)
+#else
+/* I don't think this will be needed (ToDo: #error?) */
+#endif                               
+#endif                               
+#endif                               
+
+
+#if defined(_GC_DEBUG)
+
+#define DEBUG_SCAN_LINK(type, sizevar, ptrvar) \
+    if (SM_trace & 2)                  \
+        fprintf(stderr, "Scan Link (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
+		type, Scan, New, INFO_PTR(Scan), sizevar, ptrvar)
+
+#define DEBUG_SCAN_MOVE(type, sizevar) \
+    if (SM_trace & 2)            \
+        fprintf(stderr, "Scan Move (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \
+		type, Scan, New, INFO_PTR(New), sizevar)
+
+
+#else
+
+#define DEBUG_SCAN_LINK(type, sizevar, ptrvar)
+#define DEBUG_SCAN_MOVE(type, sizevar)
+
+#endif
+
+/*** LINKING CLOSURES ***/
+
+I_
+_ScanLink_1_0(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 1, 0);
+    return(FIXED_HS + 1);	/* SPEC_VHS is defined to be 0, so "size" really is 1 */
+}
+I_
+_ScanLink_2_0(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 2, 0);
+    return(FIXED_HS + 2);
+}
+I_
+_ScanLink_3_0(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 3, 0);
+    return(FIXED_HS + 3);
+}
+I_
+_ScanLink_4_0(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 4, 0);
+    return(FIXED_HS + 4);
+}
+I_
+_ScanLink_5_0(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 5, 0);
+    return(FIXED_HS + 5);
+}
+
+I_
+_ScanLink_2_1(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 2, 1);
+    SPEC_LINK_LOCATION(1);
+    return(FIXED_HS + 2);
+}
+I_
+_ScanLink_3_1(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 3, 1);
+    SPEC_LINK_LOCATION(1);
+    return(FIXED_HS + 3);
+}
+I_
+_ScanLink_3_2(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 3, 2);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    return(FIXED_HS + 3);
+}
+
+I_
+_ScanLink_1_1(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 1, 1);
+    SPEC_LINK_LOCATION(1);
+    return(FIXED_HS + 1);
+}
+I_
+_ScanLink_2_2(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 2, 2);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    return(FIXED_HS + 2);
+}
+I_
+_ScanLink_3_3(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 3, 3);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    return(FIXED_HS + 3);
+}
+I_
+_ScanLink_4_4(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 4, 4);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    return(FIXED_HS + 4);
+}
+I_
+_ScanLink_5_5(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 5, 5);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    return(FIXED_HS + 5);
+}
+I_
+_ScanLink_6_6(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 6, 6);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    SPEC_LINK_LOCATION(6);
+    return(FIXED_HS + 6);
+}
+I_
+_ScanLink_7_7(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 7, 7);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    SPEC_LINK_LOCATION(6);
+    SPEC_LINK_LOCATION(7);
+    return(FIXED_HS + 7);
+}
+I_
+_ScanLink_8_8(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 8, 8);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    SPEC_LINK_LOCATION(6);
+    SPEC_LINK_LOCATION(7);
+    SPEC_LINK_LOCATION(8);
+    return(FIXED_HS + 8);
+}
+I_
+_ScanLink_9_9(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 9, 9);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    SPEC_LINK_LOCATION(6);
+    SPEC_LINK_LOCATION(7);
+    SPEC_LINK_LOCATION(8);
+    SPEC_LINK_LOCATION(9);
+    return(FIXED_HS + 9);
+}
+I_
+_ScanLink_10_10(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 10, 10);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    SPEC_LINK_LOCATION(6);
+    SPEC_LINK_LOCATION(7);
+    SPEC_LINK_LOCATION(8);
+    SPEC_LINK_LOCATION(9);
+    SPEC_LINK_LOCATION(10);
+    return(FIXED_HS + 10);
+}
+I_
+_ScanLink_11_11(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 11, 11);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    SPEC_LINK_LOCATION(6);
+    SPEC_LINK_LOCATION(7);
+    SPEC_LINK_LOCATION(8);
+    SPEC_LINK_LOCATION(9);
+    SPEC_LINK_LOCATION(10);
+    SPEC_LINK_LOCATION(11);
+    return(FIXED_HS + 11);
+}
+I_
+_ScanLink_12_12(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("SPEC", 12, 12);
+    SPEC_LINK_LOCATION(1);
+    SPEC_LINK_LOCATION(2);
+    SPEC_LINK_LOCATION(3);
+    SPEC_LINK_LOCATION(4);
+    SPEC_LINK_LOCATION(5);
+    SPEC_LINK_LOCATION(6);
+    SPEC_LINK_LOCATION(7);
+    SPEC_LINK_LOCATION(8);
+    SPEC_LINK_LOCATION(9);
+    SPEC_LINK_LOCATION(10);
+    SPEC_LINK_LOCATION(11);
+    SPEC_LINK_LOCATION(12);
+    return(FIXED_HS + 12);
+}
+\end{code}
+
+Scan-linking revertible black holes with underlying @SPEC@ closures.
+
+\begin{code}
+
+#ifdef PAR
+I_ 
+_ScanLink_RBH_2_1(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 2, 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    return(FIXED_HS + 2); /* ???? but SPEC_RBH_VHS is *not* zero! */
+}
+
+I_ 
+_ScanLink_RBH_3_1(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 3, 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    return(FIXED_HS + 3);
+}
+
+I_ 
+_ScanLink_RBH_3_3(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 3, 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    return(FIXED_HS + 3);
+}
+
+I_ 
+_ScanLink_RBH_4_1(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 4, 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    return(FIXED_HS + 4);
+}
+
+I_ 
+_ScanLink_RBH_4_4(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 4, 4);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    return(FIXED_HS + 4);
+}
+
+I_ 
+_ScanLink_RBH_5_1(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 5, 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    return(FIXED_HS + 5);
+}
+
+I_ 
+_ScanLink_RBH_5_5(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 5, 5);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    return(FIXED_HS + 5);
+}
+
+I_ 
+_ScanLink_RBH_6_6(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 6, 6);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
+    return(FIXED_HS + 6);
+}
+
+I_ 
+_ScanLink_RBH_7_7(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 7, 7);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
+    return(FIXED_HS + 7);
+}
+
+I_ 
+_ScanLink_RBH_8_8(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 8, 8);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
+    return(FIXED_HS + 8);
+}
+
+I_ 
+_ScanLink_RBH_9_9(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 9, 9);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
+    return(FIXED_HS + 9);
+}
+
+I_ 
+_ScanLink_RBH_10_10(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 10, 10);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
+    return(FIXED_HS + 10);
+}
+
+I_ 
+_ScanLink_RBH_11_11(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 11, 11);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9);
+    return(FIXED_HS + 11);
+}
+
+I_ 
+_ScanLink_RBH_12_12(STG_NO_ARGS)
+{
+    DEBUG_SCAN_LINK("SRBH", 12, 12);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9);
+    LINK_LOCATION(SPEC_RBH_BQ_LOCN + 10);
+    return(FIXED_HS + 12);
+}
+#endif
+
+\end{code}
+
+Scan-linking a MallocPtr is straightforward: exactly the same as
+@_ScanLink_[MallocPtr_SIZE]_0@.
+
+\begin{code}
+#ifndef PAR
+StgInt
+_ScanLink_MallocPtr(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("MallocPtr", MallocPtr_SIZE, 0);
+    return(FIXED_HS + MallocPtr_SIZE);
+}
+#endif /* !PAR */
+\end{code}
+
+Back to the main feature...
+
+\begin{code}
+
+/*** MOVING CLOSURES ***/
+
+I_
+_ScanMove_1(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 1);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    return(FIXED_HS + 1); /* NB: SPEC_VHS defined to be zero, so 1 really is the "size" */
+}
+I_
+_ScanMove_2(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 2);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    return(FIXED_HS + 2);
+}
+I_
+_ScanMove_3(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 3);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    return(FIXED_HS + 3);
+}
+I_
+_ScanMove_4(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 4);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    return(FIXED_HS + 4);
+}
+I_
+_ScanMove_5(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 5);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    return(FIXED_HS + 5);
+}
+I_
+_ScanMove_6(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 6);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    SPEC_SLIDE_WORD(6);
+    return(FIXED_HS + 6);
+}
+I_
+_ScanMove_7(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 7);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    SPEC_SLIDE_WORD(6);
+    SPEC_SLIDE_WORD(7);
+    return(FIXED_HS + 7);
+}
+I_
+_ScanMove_8(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 8);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    SPEC_SLIDE_WORD(6);
+    SPEC_SLIDE_WORD(7);
+    SPEC_SLIDE_WORD(8);
+    return(FIXED_HS + 8);
+}
+I_
+_ScanMove_9(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 9);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    SPEC_SLIDE_WORD(6);
+    SPEC_SLIDE_WORD(7);
+    SPEC_SLIDE_WORD(8);
+    SPEC_SLIDE_WORD(9);
+    return(FIXED_HS + 9);
+}
+I_
+_ScanMove_10(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 10);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    SPEC_SLIDE_WORD(6);
+    SPEC_SLIDE_WORD(7);
+    SPEC_SLIDE_WORD(8);
+    SPEC_SLIDE_WORD(9);
+    SPEC_SLIDE_WORD(10);
+    return(FIXED_HS + 10);
+}
+I_
+_ScanMove_11(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 11);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    SPEC_SLIDE_WORD(6);
+    SPEC_SLIDE_WORD(7);
+    SPEC_SLIDE_WORD(8);
+    SPEC_SLIDE_WORD(9);
+    SPEC_SLIDE_WORD(10);
+    SPEC_SLIDE_WORD(11);
+    return(FIXED_HS + 11);
+}
+I_
+_ScanMove_12(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SPEC", 12);
+    SLIDE_FIXED_HDR;
+    SPEC_SLIDE_WORD(1);
+    SPEC_SLIDE_WORD(2);
+    SPEC_SLIDE_WORD(3);
+    SPEC_SLIDE_WORD(4);
+    SPEC_SLIDE_WORD(5);
+    SPEC_SLIDE_WORD(6);
+    SPEC_SLIDE_WORD(7);
+    SPEC_SLIDE_WORD(8);
+    SPEC_SLIDE_WORD(9);
+    SPEC_SLIDE_WORD(10);
+    SPEC_SLIDE_WORD(11);
+    SPEC_SLIDE_WORD(12);
+    return(FIXED_HS + 12);
+}
+
+#if defined(PAR) && defined(GC_MUT_REQUIRED)
+I_
+_ScanMove_RBH_2(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 2);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 2); /* ???? SPEC_RBH_VHS is *not* zero! */
+}
+I_
+_ScanMove_RBH_3(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 3);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 3);
+}
+I_
+_ScanMove_RBH_4(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 4);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 4);
+}
+I_
+_ScanMove_RBH_5(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 5);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 5);
+}
+I_
+_ScanMove_RBH_6(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 6);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+    SLIDE_WORD(SPEC_RBH_HS + 4);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 6);
+}
+I_
+_ScanMove_RBH_7(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 7);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+    SLIDE_WORD(SPEC_RBH_HS + 4);
+    SLIDE_WORD(SPEC_RBH_HS + 5);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 7);
+}
+I_
+_ScanMove_RBH_8(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 8);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+    SLIDE_WORD(SPEC_RBH_HS + 4);
+    SLIDE_WORD(SPEC_RBH_HS + 5);
+    SLIDE_WORD(SPEC_RBH_HS + 6);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 8);
+}
+I_
+_ScanMove_RBH_9(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 9);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+    SLIDE_WORD(SPEC_RBH_HS + 4);
+    SLIDE_WORD(SPEC_RBH_HS + 5);
+    SLIDE_WORD(SPEC_RBH_HS + 6);
+    SLIDE_WORD(SPEC_RBH_HS + 7);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 9);
+}
+I_
+_ScanMove_RBH_10(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 10);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+    SLIDE_WORD(SPEC_RBH_HS + 4);
+    SLIDE_WORD(SPEC_RBH_HS + 5);
+    SLIDE_WORD(SPEC_RBH_HS + 6);
+    SLIDE_WORD(SPEC_RBH_HS + 7);
+    SLIDE_WORD(SPEC_RBH_HS + 8);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 10);
+}
+I_
+_ScanMove_RBH_11(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 11);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+    SLIDE_WORD(SPEC_RBH_HS + 4);
+    SLIDE_WORD(SPEC_RBH_HS + 5);
+    SLIDE_WORD(SPEC_RBH_HS + 6);
+    SLIDE_WORD(SPEC_RBH_HS + 7);
+    SLIDE_WORD(SPEC_RBH_HS + 8);
+    SLIDE_WORD(SPEC_RBH_HS + 9);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 11);
+}
+I_
+_ScanMove_RBH_12(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("SRBH", 12);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(SPEC_RBH_HS + 0);
+    SLIDE_WORD(SPEC_RBH_HS + 1);
+    SLIDE_WORD(SPEC_RBH_HS + 2);
+    SLIDE_WORD(SPEC_RBH_HS + 3);
+    SLIDE_WORD(SPEC_RBH_HS + 4);
+    SLIDE_WORD(SPEC_RBH_HS + 5);
+    SLIDE_WORD(SPEC_RBH_HS + 6);
+    SLIDE_WORD(SPEC_RBH_HS + 7);
+    SLIDE_WORD(SPEC_RBH_HS + 8);
+    SLIDE_WORD(SPEC_RBH_HS + 9);
+    SLIDE_WORD(SPEC_RBH_HS + 10);
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + 12);
+}
+#endif
+\end{code}
+
+Moving a Malloc Pointer is a little tricky: we want to copy the actual
+pointer unchanged (easy) but we want to link the MallocPtr into the
+new MallocPtr list.
+
+\begin{code}
+#ifndef PAR
+StgInt
+_ScanMove_MallocPtr(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("MallocPtr", MallocPtr_SIZE);
+
+#if defined(_GC_DEBUG)
+    if (SM_trace & 16) {
+      printf("Moving MallocPtr(%x)=<%x,%x,%x>", Scan, Scan[0], Scan[1], Scan[2]);
+      printf(" Data = %x, Next = %x\n", 
+	     MallocPtr_CLOSURE_DATA(Scan), MallocPtr_CLOSURE_LINK(Scan) );
+    }
+#endif
+
+    SLIDE_FIXED_HDR;
+    MallocPtr_SLIDE_DATA;
+    MallocPtr_RELINK;
+
+#if defined(_GC_DEBUG)
+    if (SM_trace & 16) {
+      printf("Moved MallocPtr(%x)=<%x,_,%x,%x,%x>", New, New[0], New[1], New[2], New[3]);
+      printf(" Data = %x, Next = %x", 
+	     MallocPtr_CLOSURE_DATA(New), MallocPtr_CLOSURE_LINK(New) );
+      printf(", NewMallocPtrList = %x\n", NewMallocPtrList );
+    }
+#endif
+
+    return(FIXED_HS + MallocPtr_SIZE);
+}
+#endif /* !PAR */
+\end{code}
+
+Now back to the main feature...
+
+\begin{code}
+
+/*** GENERIC Linking and Marking Routines */
+
+I_
+_ScanLink_S_N(STG_NO_ARGS) {
+    I_ count = GEN_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs  = count + GEN_CLOSURE_NoPTRS(Scan);
+                   /* Offset of last ptr word */
+    I_ size  = GEN_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_LINK("GEN ", size, ptrs);
+    while (++count <= ptrs) {
+	LINK_LOCATION(count);
+    }
+    return(FIXED_HS + size);
+}
+
+I_
+_ScanMove_S(STG_NO_ARGS) {
+    I_ count = FIXED_HS - 1;
+    I_ size  = GEN_CLOSURE_SIZE(New);
+
+    DEBUG_SCAN_MOVE("GEN ", size);
+
+    SLIDE_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	SLIDE_WORD(count);
+    }
+    return(FIXED_HS + size);
+}
+
+\end{code}
+
+The linking code for revertible black holes with underlying @GEN@ closures.
+
+\begin{code}
+#ifdef PAR
+
+I_ 
+_ScanLink_RBH_N(STG_NO_ARGS)
+{
+    I_ count = GEN_RBH_HS - 1;	/* Offset of first ptr word, less 1 */
+    I_ ptrs  = GEN_RBH_CLOSURE_NoPTRS(Scan);
+    I_ size  = GEN_RBH_CLOSURE_SIZE(Scan);
+
+    /* 
+     * Get pointer count from original closure and adjust for one pointer 
+     * in the first two words of the RBH.
+     */
+    if (ptrs < 2)
+	ptrs = 1;
+    else
+	ptrs--;
+
+    ptrs += count;	    /* Offset of last ptr word */
+
+    DEBUG_SCAN_LINK("GRBH", size, ptrs);
+    while (++count <= ptrs) {
+	LINK_LOCATION(count);
+    }
+    return(FIXED_HS + size);
+}
+
+#ifdef GC_MUT_REQUIRED
+
+I_
+_ScanMove_RBH_S(STG_NO_ARGS) {
+    I_ count = GEN_RBH_HS - 1;
+    I_ size  = GEN_RBH_CLOSURE_SIZE(New);
+
+    DEBUG_SCAN_MOVE("GRBH", size);
+
+    SLIDE_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	SLIDE_WORD(count);
+    }
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + size);
+}
+
+#endif
+
+#endif
+
+\end{code}
+
+\begin{code}
+I_
+_ScanLink_Dyn(STG_NO_ARGS) {
+    I_ count = DYN_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs = count + DYN_CLOSURE_NoPTRS(Scan);
+                   /* Offset of last ptr word */
+    I_ size = DYN_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_LINK("DYN ", size, ptrs-count);
+
+    while (++count <= ptrs) {
+	LINK_LOCATION(count);
+    }
+    return(FIXED_HS + size);
+}
+
+I_
+_ScanMove_Dyn(STG_NO_ARGS) {
+    I_ count = FIXED_HS - 1;
+    I_ size  = DYN_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_MOVE("DYN ", size);
+
+    SLIDE_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	SLIDE_WORD(count);
+    }
+    return(FIXED_HS + size);
+}
+
+I_
+_ScanLink_Tuple(STG_NO_ARGS) {
+    I_ count = TUPLE_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs = count + TUPLE_CLOSURE_NoPTRS(Scan);
+                   /* Offset of last ptr word */
+    I_ size = TUPLE_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_LINK("TUPL", size, ptrs-count);
+
+    while (++count <= ptrs) {
+	LINK_LOCATION(count);
+    }
+    return(FIXED_HS + size);
+}
+
+I_
+_ScanMove_Tuple(STG_NO_ARGS) {
+    I_ count = FIXED_HS - 1;
+    I_ size  = TUPLE_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_MOVE("TUPL", size);
+
+    SLIDE_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	SLIDE_WORD(count);
+    }
+    return(FIXED_HS + size);
+}
+
+/*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
+/*             Only if special GC treatment required           */
+
+#ifdef GC_MUT_REQUIRED
+I_
+_ScanLink_MuTuple(STG_NO_ARGS) {
+    I_ count = MUTUPLE_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs = count + MUTUPLE_CLOSURE_NoPTRS(Scan);
+                   /* Offset of last ptr word */
+    I_ size = MUTUPLE_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_LINK("MUT ", size, ptrs-count);
+
+    while (++count <= ptrs) {
+	LINK_LOCATION(count);
+    }
+    return(FIXED_HS + size);
+}
+
+I_
+_ScanMove_MuTuple(STG_NO_ARGS) {
+    I_ count = FIXED_HS - 1;
+    I_ size  = MUTUPLE_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_MOVE("MUT ", size);
+
+    SLIDE_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	SLIDE_WORD(count);
+    }
+
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+
+    return(FIXED_HS + size);
+}
+
+I_
+_ScanMove_ImmuTuple(STG_NO_ARGS) {
+    I_ count = FIXED_HS - 1;
+    I_ size  = MUTUPLE_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_MOVE("IMUT", size);
+
+    SLIDE_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	SLIDE_WORD(count);
+    }
+
+    /* Dont add to OldMutables list */
+
+    return(FIXED_HS + size);
+}
+#endif /* GCap || GCgn */
+
+
+I_
+_ScanLink_Data(STG_NO_ARGS) {
+    I_ size  = DATA_CLOSURE_SIZE(Scan);
+    DEBUG_SCAN_LINK("DATA", size, 0);
+    return(FIXED_HS + size);
+}
+
+I_
+_ScanMove_Data(STG_NO_ARGS) {
+    I_ count = FIXED_HS - 1;
+    I_ size  = DATA_CLOSURE_SIZE(Scan);
+
+    DEBUG_SCAN_MOVE("DATA", size);
+
+    SLIDE_FIXED_HDR;
+    while (++count <= size + (FIXED_HS - 1)) {
+	SLIDE_WORD(count);
+    }
+    return(FIXED_HS + size);
+}
+
+
+I_
+_ScanLink_BH_U(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("BH  ", MIN_UPD_SIZE, 0);
+    return(FIXED_HS + BH_U_SIZE); /* size includes _VHS */
+    /* NB: pretty intimate knowledge about BH closure layout */
+}
+
+I_
+_ScanMove_BH_U(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("BH  ", MIN_UPD_SIZE);
+    SLIDE_FIXED_HDR;
+    return(FIXED_HS  + BH_U_SIZE);
+    /* ditto */
+}
+
+I_
+_ScanLink_BH_N(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("BH N", MIN_NONUPD_SIZE, 0);
+    return(FIXED_HS + BH_N_SIZE); /* size includes _VHS */
+    /* NB: pretty intimate knowledge about BH closure layout */
+}
+
+I_
+_ScanMove_BH_N(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("BH N",MIN_NONUPD_SIZE);
+    SLIDE_FIXED_HDR;
+    return(FIXED_HS + BH_N_SIZE);
+    /* ditto */
+}
+
+#ifdef USE_COST_CENTRES
+I_
+_ScanLink_PI(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("PI  ", IND_CLOSURE_SIZE(dummy), 1);
+    LINK_LOCATION(IND_HS);
+    return(FIXED_HS + IND_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+}
+
+I_
+_ScanMove_PI(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("PI  ", IND_CLOSURE_SIZE(dummy));
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(IND_HS);
+    return(FIXED_HS + IND_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+}
+#endif
+
+\end{code}
+
+Linking and Marking Routines for FetchMes and stack objects.
+
+\begin{code}
+
+#if defined(CONCURRENT)
+
+#if defined(PAR)
+
+I_
+_ScanLink_FetchMe(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("FME ", MIN_UPD_SIZE, 0);
+    return(FIXED_HS + FETCHME_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+}
+
+I_
+_ScanMove_FetchMe(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("FME ",MIN_UPD_SIZE);
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(FETCHME_GA_LOCN);
+    ASSERT(GALAlookup(FETCHME_GA(New)) != NULL);
+
+#ifdef GC_MUT_REQUIRED
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+#endif
+
+    return(FIXED_HS + FETCHME_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+}
+
+I_
+_ScanLink_BF(STG_NO_ARGS) 
+{
+    DEBUG_SCAN_LINK("BF", BF_HS, 2 /*possibly wrong (WDP 95/07)*/);
+
+    LINK_LOCATION(BF_LINK_LOCN);
+    LINK_LOCATION(BF_NODE_LOCN);
+    return(FIXED_HS + BF_CLOSURE_SIZE(dummy));
+}
+
+I_
+_ScanMove_BF(STG_NO_ARGS) 
+{
+    I_ count;
+
+    SLIDE_FIXED_HDR;
+    for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) {
+    	SLIDE_WORD(count);
+    }
+    SLIDE_WORD(BF_LINK_LOCN);
+    SLIDE_WORD(BF_NODE_LOCN);
+    SLIDE_WORD(BF_GTID_LOCN);
+    SLIDE_WORD(BF_SLOT_LOCN);
+    SLIDE_WORD(BF_WEIGHT_LOCN);
+
+#ifdef GC_MUT_REQUIRED
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+#endif
+
+    return(FIXED_HS + BF_CLOSURE_SIZE(dummy));
+}
+
+#endif	/* PAR */
+
+I_
+_ScanLink_BQ(STG_NO_ARGS) {
+    DEBUG_SCAN_LINK("BQ  ", BQ_CLOSURE_SIZE(dummy), BQ_CLOSURE_NoPTRS(Scan));
+    LINK_LOCATION(BQ_HS);
+    return(FIXED_HS + BQ_CLOSURE_SIZE(dummy));
+}
+
+I_
+_ScanMove_BQ(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("BQ  ", BQ_CLOSURE_SIZE(dummy));
+
+    SLIDE_FIXED_HDR;
+    SLIDE_WORD(BQ_HS);
+
+#ifdef GC_MUT_REQUIRED
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+#endif
+
+    return(FIXED_HS + BQ_CLOSURE_SIZE(dummy));
+}
+
+I_
+_ScanLink_TSO(STG_NO_ARGS) 
+{
+    STGRegisterTable *r = TSO_INTERNAL_PTR(Scan);
+    W_ liveness = r->rLiveness;
+    I_ i;
+
+    DEBUG_SCAN_LINK("TSO", TSO_HS + TSO_CTS_SIZE, 0/*wrong*/);
+
+    LINK_LOCATION(TSO_LINK_LOCN);
+    LINK_LOCATION(((P_) &r->rStkO) - Scan);
+    for(i = 0; liveness != 0; liveness >>= 1, i++) {
+    	if (liveness & 1) {
+    	    LINK_LOCATION(((P_) &r->rR[i].p) - Scan)
+    	}
+    }
+    return(TSO_HS + TSO_CTS_SIZE);
+}
+
+I_
+_ScanMove_TSO(STG_NO_ARGS) 
+{
+    I_ count;
+
+    SLIDE_FIXED_HDR;
+    for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) {
+    	SLIDE_WORD(count);
+    }
+
+    for(count = 0; count < BYTES_TO_STGWORDS(sizeof(STGRegisterTable)); count++)
+    	/* Do it this way in case there's a shift of just one word */
+        ((P_) TSO_INTERNAL_PTR(New))[count] = ((P_) TSO_INTERNAL_PTR(Scan))[count];
+
+#ifdef GC_MUT_REQUIRED
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+#endif
+
+    return(TSO_HS + TSO_CTS_SIZE);
+}
+
+I_
+_ScanLink_StkO(STG_NO_ARGS) {
+    I_ count;
+    I_ size = STKO_CLOSURE_SIZE(Scan);
+    I_ cts_size = STKO_CLOSURE_CTS_SIZE(Scan);
+    I_ sub = STKO_SuB_OFFSET(Scan);	/* Offset of first update frame in B stack */
+
+    /* Link the link */
+    LINK_LOCATION(STKO_LINK_LOCN);
+
+    /* Link the locations in the A stack */
+    DEBUG_SCAN_LINK("STKO", size, cts_size - STKO_SpA_OFFSET(SCAN) + 1);
+    for (count = STKO_SpA_OFFSET(Scan); count <= cts_size; count++) {
+	STKO_LINK_LOCATION(count);
+    }
+
+    /* Now link the updatees in the update stack */
+    while(sub > 0) {
+    	P_ subptr;
+
+    	STKO_LINK_LOCATION(sub + BREL(UF_UPDATEE));
+    	subptr = GRAB_SuB(STKO_CLOSURE_ADDR(Scan,sub));
+	sub = STKO_CLOSURE_OFFSET(Scan, subptr);
+    }
+
+    /*
+       I assume what's wanted is the size of the object 
+       rather the number of pointers in the object. KH 
+    */
+    return(FIXED_HS + size);
+}
+
+/* We move first and then repair, so that we can handle an overlapping source 
+   and destination.
+ */
+
+I_
+_ScanMove_StkO(STG_NO_ARGS) {
+    I_ count;
+    I_ size  = STKO_CLOSURE_SIZE(Scan);
+    I_ cts_size   = STKO_CLOSURE_CTS_SIZE(Scan);
+    I_ spa_offset = STKO_SpA_OFFSET(Scan);
+    I_ spb_offset = STKO_SpB_OFFSET(Scan);
+    I_ sub_offset = STKO_SuB_OFFSET(Scan);
+    I_ offset;
+    
+    DEBUG_SCAN_MOVE("STKO", size);
+
+    SLIDE_FIXED_HDR;
+#ifdef DO_REDN_COUNTING
+    SLIDE_WORD(STKO_ADEP_LOCN);
+    SLIDE_WORD(STKO_BDEP_LOCN);
+#endif
+    SLIDE_WORD(STKO_SIZE_LOCN);
+    SLIDE_WORD(STKO_RETURN_LOCN);
+    SLIDE_WORD(STKO_LINK_LOCN);
+
+    /* Adjust the four stack pointers...*IN ORDER* */
+    offset = New - Scan;
+    STKO_SuB(New) = STKO_SuB(Scan) + offset;
+    STKO_SpB(New) = STKO_SpB(Scan) + offset;
+    STKO_SpA(New) = STKO_SpA(Scan) + offset;
+    STKO_SuA(New) = STKO_SuA(Scan) + offset;
+
+    /* Slide the B stack */
+    for (count = 1; count <= spb_offset; count++) {
+	SLIDE_WORD((STKO_HS-1) + count);
+    }
+
+    /* Slide the A stack */
+    for (count = spa_offset; count <= cts_size; count++) {
+	SLIDE_WORD((STKO_HS-1) + count);
+    }
+
+    /* Repair internal pointers */
+    while (sub_offset > 0) {
+    	    P_ subptr;
+	    ADJUST_WORD((STKO_HS-1) + sub_offset + BREL(UF_SUA),offset);
+	    ADJUST_WORD((STKO_HS-1) + sub_offset + BREL(UF_SUB),offset);
+    	    subptr = GRAB_SuB(STKO_CLOSURE_ADDR(New,sub_offset));
+    	    sub_offset = STKO_CLOSURE_OFFSET(New, subptr);
+    }
+
+#ifdef GC_MUT_REQUIRED
+    /* Build new OldMutables list */
+    MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
+    StorageMgrInfo.OldMutables = (P_) New;
+#endif
+
+    return(FIXED_HS + size);
+}
+
+#endif /* CONCURRENT */
+
+\end{code}
+
+\begin{code}
+#if defined(GCgn)
+I_
+_ScanMove_OldRoot(STG_NO_ARGS) {
+    DEBUG_SCAN_MOVE("OLDR", 2);
+    SLIDE_FIXED_HDR;
+    IND_CLOSURE_PTR(New) = IND_CLOSURE_PTR(Scan);
+    IND_CLOSURE_LINK(New) = (W_) genInfo.OldInNew;
+    genInfo.OldInNew = New;
+    genInfo.OldInNewno++;
+    return(IND_HS + MIN_UPD_SIZE); /* this looks wrong (WDP 95/07) */
+}
+#endif /* GCgn */
+
+/*** Dummy Entries -- Should not be entered ***/
+
+/* Should not be in a .lc file either...  --JSM */
+
+STGFUN(_Dummy_Static_entry) {
+    fprintf(stderr,"Called _Dummy_Static_entry\nShould never occur!\n");
+    abort();
+}
+
+STGFUN(_Dummy_Ind_entry) {
+    fprintf(stderr,"Called _Dummy_Ind_entry\nShould never occur!\n");
+    abort();
+}
+
+STGFUN(_Dummy_Caf_entry) {
+    fprintf(stderr,"Called _Dummy_Caf_Ind_entry\nShould never occur!\n");
+    abort();
+}
+
+STGFUN(_Dummy_Const_entry) {
+    fprintf(stderr,"Called _Dummy_Const_entry\nShould never occur!\n");
+    abort();
+}
+
+STGFUN(_Dummy_CharLike_entry) {
+    fprintf(stderr,"Called _Dummy_CharLike_entry\nShould never occur!\n");
+    abort();
+}
+
+#endif /* _INFO_COMPACTING */
+
+\end{code}
diff --git a/ghc/runtime/storage/SMscav.lc b/ghc/runtime/storage/SMscav.lc
new file mode 100644
index 0000000000..2bc6ab2ebe
--- /dev/null
+++ b/ghc/runtime/storage/SMscav.lc
@@ -0,0 +1,1031 @@
+****************************************************************************
+
+The files SMevac.lc and SMscav.lhc contain the basic routines required
+for two-space copying garbage collection.
+
+Two files are required as the evac routines are conventional call/return
+routines while the scavenge routines are continuation routines.
+
+This file SMscav.lhc contains the scavenging routines ...
+
+****************************************************************************
+
+
+All the routines are placed in the info tables of the appropriate closures.
+
+
+Evacuation code:  _Evacuate_...
+
+USE:  new = EVACUATE_CLOSURE(evac)
+
+Evacuates a closure of size S words. Note the size excludes the info
+and any other preceding fields (eg global address in Grip implementation)
+Returns the address of the closures new location via the Evac register.
+
+  Calling Conventions:
+    arg   -- points to the closure
+    ToHp  -- points to the last allocated word in to-space
+  Return Conventions:
+    ret   -- points to the new address of the closure
+    ToHp  -- points to the last allocated word in to-space
+
+  Example: Cons cell requires _Evacuate_2
+
+Scavenging code:  _Scavenge_S_N
+
+  Retrieved using SCAV_CODE(infoptr)
+
+Scavenges a closure of size S words, with N pointers and returns.
+If more closures are required to be scavenged the code to
+scan the next closure can be called.
+
+  Calling Conventions:
+    Scav  -- points to the current closure
+    ToHp  -- points to the last allocated word in to-space
+
+    OldGen -- Points to end of old generation (Appels collector only)
+
+  Return Conventions:
+    Scav -- points to the next closure
+    ToHp -- points to the (possibly new) location of the last allocated word
+
+  Example: Cons cell requires _Scavenge_2_2
+
+
+The following registers are used by a two-space collection:
+
+Scav	-- Points to the current closure being scavenged
+           (PS paper = Hscav)
+
+ToHp     -- Points to the last word allocated in two-space
+           (PS paper = Hnext)
+
+A copying pass is started by:
+    -- Setting ToHp to 1 before the start of to-space
+    -- Evacuating the roots pointing into from-space
+         -- root = EVACUATE_CLOSURE(root)
+    -- Setting Scav to point to the first closure in to-space
+    -- Execute  while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+
+When Done ToHp will point to the last word allocated in to-space
+
+
+\begin{code}
+/* The #define and #include come before the test because SMinternal.h
+   will suck in includes/SMinterface whcih defines (or doesn't)
+   _INFO_COPYING [ADR] */
+
+#define SCAV_REG_MAP
+#include "SMinternal.h"
+
+#if defined(_INFO_COPYING)
+
+RegisterTable ScavRegTable;
+
+/* Moves Scav to point at the info pointer of the next closure to Scavenge */
+#define NEXT_Scav(size)    Scav += (size) + FIXED_HS
+
+/* 
+   When doing a new generation copy collection for Appel's collector
+   only evacuate references that point to the new generation.
+   OldGen must be set to point to the end of old space.
+*/
+
+#if defined(GCgn)
+
+#define DO_EVACUATE(closure, pos) \
+            { P_ evac = (P_) *(((P_)(closure))+(pos)); \
+              if (evac > OldGen) {                \
+		*(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); \
+	    }}
+
+#else
+#if defined(GCap)
+
+#define DO_EVACUATE(closure, pos) \
+            { P_ evac = (P_) *(((P_)(closure))+(pos)); \
+              if (evac > OldGen) {                \
+		*(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); \
+	    }}
+
+#else /* ! GCgn && ! GCap */
+
+#define DO_EVACUATE(closure, pos) \
+            { P_ evac = (P_) *(((P_)(closure))+(pos));  \
+	      *(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); }
+
+#endif /* ! GCgn && ! GCap */
+#endif
+
+
+/* Evacuate nth pointer in SPEC closure (starting at 1) */
+#define SPEC_DO_EVACUATE(ptr) DO_EVACUATE(Scav, (SPEC_HS-1) + (ptr))
+#define STKO_DO_EVACUATE(ptr) DO_EVACUATE(Scav, (STKO_HS-1) + (ptr))
+
+
+/*** DEBUGGING MACROS ***/
+
+#if defined(_GC_DEBUG)
+
+#define DEBUG_SCAV(s,p) \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
+		Scav, INFO_PTR(Scav), s, p)
+
+#define DEBUG_SCAV_GEN(s,p) \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, Gen info 0x%lx, size %ld, ptrs %ld\n", \
+		Scav, INFO_PTR(Scav), s, p)
+
+#define DEBUG_SCAV_DYN   \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, Dyn info 0x%lx, size %ld, ptrs %ld\n", \
+		Scav, INFO_PTR(Scav), DYN_CLOSURE_SIZE(Scav), DYN_CLOSURE_NoPTRS(Scav))
+
+#define DEBUG_SCAV_TUPLE \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, Tuple info 0x%lx, size %ld, ptrs %ld\n", \
+		Scav, INFO_PTR(Scav), TUPLE_CLOSURE_SIZE(Scav), TUPLE_CLOSURE_NoPTRS(Scav))
+
+#define DEBUG_SCAV_MUTUPLE \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, MuTuple info 0x%lx, size %ld, ptrs %ld\n", \
+		Scav, INFO_PTR(Scav), MUTUPLE_CLOSURE_SIZE(Scav), MUTUPLE_CLOSURE_NoPTRS(Scav))
+
+#define DEBUG_SCAV_DATA  \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, Data info 0x%lx, size %ld\n", \
+		Scav, INFO_PTR(Scav), DATA_CLOSURE_SIZE(Scav))
+
+#define DEBUG_SCAV_BH(s)  \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, BH info 0x%lx, size %ld\n", \
+		Scav, INFO_PTR(Scav), s)
+
+#define DEBUG_SCAV_IND \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, IND info 0x%lx, size %ld\n", \
+		Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav))
+
+#define DEBUG_SCAV_PERM_IND \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, PI info 0x%lx, size %ld\n", \
+		Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav))
+
+#define DEBUG_SCAV_OLDROOT(s) \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: OLDROOT 0x%lx, info 0x%lx, size %ld\n", \
+		Scav, INFO_PTR(Scav), s)
+
+#ifdef CONCURRENT
+#define DEBUG_SCAV_BQ \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, BQ info 0x%lx, size %ld, ptrs %ld\n", \
+		Scav, INFO_PTR(Scav), BQ_CLOSURE_SIZE(Scav), BQ_CLOSURE_NoPTRS(Scav))
+
+#define DEBUG_SCAV_TSO  \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav TSO: 0x%lx\n", \
+		Scav)
+
+#define DEBUG_SCAV_STKO  \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav StkO: 0x%lx\n", \
+		Scav)
+
+# ifdef PAR
+#  define DEBUG_SCAV_BF \
+    if (SM_trace & 2) \
+        fprintf(stderr, "Scav: 0x%lx, BF info 0x%lx, size %ld, ptrs %ld\n", \
+		Scav, INFO_PTR(Scav), BF_CLOSURE_SIZE(dummy), 0)
+# endif
+#endif
+
+#else
+
+#define DEBUG_SCAV(s,p)
+#define DEBUG_SCAV_GEN(s,p)
+#define DEBUG_SCAV_DYN
+#define DEBUG_SCAV_TUPLE
+#define DEBUG_SCAV_MUTUPLE
+#define DEBUG_SCAV_DATA
+#define DEBUG_SCAV_BH(s)
+#define DEBUG_SCAV_IND
+#define DEBUG_SCAV_PERM_IND
+#define DEBUG_SCAV_OLDROOT(s)
+
+#ifdef CONCURRENT
+# define DEBUG_SCAV_BQ
+# define DEBUG_SCAV_TSO
+# define DEBUG_SCAV_STKO
+# ifdef PAR
+#  define DEBUG_SCAV_BF
+# endif
+#endif
+
+#endif
+
+#define PROFILE_CLOSURE(closure,size) \
+    HEAP_PROFILE_CLOSURE(closure,size); \
+    LIFE_PROFILE_CLOSURE(closure,size)
+
+/*** SPECIALISED CODE ***/
+
+void
+_Scavenge_1_0(STG_NO_ARGS)
+{
+    DEBUG_SCAV(1,0);
+    PROFILE_CLOSURE(Scav,1);
+    NEXT_Scav(1); /* because "size" is defined to be 1 (size SPEC_VHS == 0) */
+    return;
+}
+void
+_Scavenge_2_0(STG_NO_ARGS)
+{
+    DEBUG_SCAV(2,0);
+    PROFILE_CLOSURE(Scav,2);
+    NEXT_Scav(2);
+    return;
+}
+void
+_Scavenge_3_0(STG_NO_ARGS)
+{
+    DEBUG_SCAV(3,0);
+    PROFILE_CLOSURE(Scav,3);
+    NEXT_Scav(3);
+    return;
+}
+void
+_Scavenge_4_0(STG_NO_ARGS)
+{
+    DEBUG_SCAV(4,0);
+    PROFILE_CLOSURE(Scav,4);
+    NEXT_Scav(4);
+    return;
+}
+void
+_Scavenge_5_0(STG_NO_ARGS)
+{
+    DEBUG_SCAV(5,0);
+    PROFILE_CLOSURE(Scav,5);
+    NEXT_Scav(5);
+    return;
+}
+
+void
+_Scavenge_2_1(STG_NO_ARGS)
+{
+    DEBUG_SCAV(2,1);
+    PROFILE_CLOSURE(Scav,2);
+    SPEC_DO_EVACUATE(1);
+    NEXT_Scav(2);
+    return;
+}
+
+void
+_Scavenge_3_1(STG_NO_ARGS)
+{
+    DEBUG_SCAV(3,1);
+    PROFILE_CLOSURE(Scav,3);
+    SPEC_DO_EVACUATE(1);
+    NEXT_Scav(3);
+    return;
+}
+void
+_Scavenge_3_2(STG_NO_ARGS)
+{
+    DEBUG_SCAV(3,2);
+    PROFILE_CLOSURE(Scav,3);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    NEXT_Scav(3);
+    return;
+}
+
+void
+_Scavenge_1_1(STG_NO_ARGS)
+{
+    DEBUG_SCAV(1,1);
+    PROFILE_CLOSURE(Scav,1);
+    SPEC_DO_EVACUATE(1);
+    NEXT_Scav(1);
+    return;
+}
+void
+_Scavenge_2_2(STG_NO_ARGS)
+{
+    DEBUG_SCAV(2,2);
+    PROFILE_CLOSURE(Scav,2);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    NEXT_Scav(2);
+    return;
+}
+void
+_Scavenge_3_3(STG_NO_ARGS)
+{
+    DEBUG_SCAV(3,3);
+    PROFILE_CLOSURE(Scav,3);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    NEXT_Scav(3);
+    return;
+}
+void
+_Scavenge_4_4(STG_NO_ARGS)
+{
+    DEBUG_SCAV(4,4);
+    PROFILE_CLOSURE(Scav,4);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    NEXT_Scav(4);
+    return;
+}
+void
+_Scavenge_5_5(STG_NO_ARGS)
+{
+    DEBUG_SCAV(5,5);
+    PROFILE_CLOSURE(Scav,5);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    NEXT_Scav(5);
+    return;
+}
+void
+_Scavenge_6_6(STG_NO_ARGS)
+{
+    DEBUG_SCAV(6,6);
+    PROFILE_CLOSURE(Scav,6);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    SPEC_DO_EVACUATE(6);
+    NEXT_Scav(6);
+    return;
+}
+void
+_Scavenge_7_7(STG_NO_ARGS)
+{
+    DEBUG_SCAV(7,7);
+    PROFILE_CLOSURE(Scav,7);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    SPEC_DO_EVACUATE(6);
+    SPEC_DO_EVACUATE(7);
+    NEXT_Scav(7);
+    return;
+}
+void
+_Scavenge_8_8(STG_NO_ARGS)
+{
+    DEBUG_SCAV(8,8);
+    PROFILE_CLOSURE(Scav,8);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    SPEC_DO_EVACUATE(6);
+    SPEC_DO_EVACUATE(7);
+    SPEC_DO_EVACUATE(8);
+    NEXT_Scav(8);
+    return;
+}
+void
+_Scavenge_9_9(STG_NO_ARGS)
+{
+    DEBUG_SCAV(9,9);
+    PROFILE_CLOSURE(Scav,9);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    SPEC_DO_EVACUATE(6);
+    SPEC_DO_EVACUATE(7);
+    SPEC_DO_EVACUATE(8);
+    SPEC_DO_EVACUATE(9);
+    NEXT_Scav(9);
+    return;
+}
+void
+_Scavenge_10_10(STG_NO_ARGS)
+{
+    DEBUG_SCAV(10,10);
+    PROFILE_CLOSURE(Scav,10);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    SPEC_DO_EVACUATE(6);
+    SPEC_DO_EVACUATE(7);
+    SPEC_DO_EVACUATE(8);
+    SPEC_DO_EVACUATE(9);
+    SPEC_DO_EVACUATE(10);
+    NEXT_Scav(10);
+    return;
+}
+void
+_Scavenge_11_11(STG_NO_ARGS)
+{
+    DEBUG_SCAV(11,11);
+    PROFILE_CLOSURE(Scav,11);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    SPEC_DO_EVACUATE(6);
+    SPEC_DO_EVACUATE(7);
+    SPEC_DO_EVACUATE(8);
+    SPEC_DO_EVACUATE(9);
+    SPEC_DO_EVACUATE(10);
+    SPEC_DO_EVACUATE(11);
+    NEXT_Scav(11);
+    return;
+}
+void
+_Scavenge_12_12(STG_NO_ARGS)
+{
+    DEBUG_SCAV(12,12);
+    PROFILE_CLOSURE(Scav,12);
+    SPEC_DO_EVACUATE(1);
+    SPEC_DO_EVACUATE(2);
+    SPEC_DO_EVACUATE(3);
+    SPEC_DO_EVACUATE(4);
+    SPEC_DO_EVACUATE(5);
+    SPEC_DO_EVACUATE(6);
+    SPEC_DO_EVACUATE(7);
+    SPEC_DO_EVACUATE(8);
+    SPEC_DO_EVACUATE(9);
+    SPEC_DO_EVACUATE(10);
+    SPEC_DO_EVACUATE(11);
+    SPEC_DO_EVACUATE(12);
+    NEXT_Scav(12);
+    return;
+}
+\end{code}
+
+The scavenge routines for revertible black holes with underlying @SPEC@
+closures.
+
+\begin{code}
+
+#ifdef PAR
+
+# if defined(GCgn)
+
+#  define SCAVENGE_SPEC_RBH_N_1(n)	\
+void					\
+CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS)	\
+{					\
+    P_ save_Scav;			\
+    DEBUG_SCAV(n,1);			\
+    save_Scav = Scav;			\
+    Scav = OldGen + 1;			\
+    DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN);	\
+    Scav = save_Scav;			\
+    PROFILE_CLOSURE(Scav,n);		\
+    NEXT_Scav(n); /* ToDo: dodgy size WDP 95/07 */			\
+}
+
+#  define SCAVENGE_SPEC_RBH_N_N(n)	\
+void					\
+CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \
+{					\
+    int i;				\
+    P_ save_Scav;			\
+    DEBUG_SCAV(n,n-1);			\
+    save_Scav = Scav;			\
+    Scav = OldGen + 1;			\
+    for(i = 0; i < n - 1; i++) {	\
+        DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN + i);	\
+    }					\
+    Scav = save_Scav;			\
+    PROFILE_CLOSURE(Scav,n);		\
+    NEXT_Scav(n);			\
+}
+
+# else
+
+#  define SCAVENGE_SPEC_RBH_N_1(n)	\
+void					\
+CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS)	\
+{					\
+    DEBUG_SCAV(n,1);			\
+    DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN);\
+    PROFILE_CLOSURE(Scav,n);		\
+    NEXT_Scav(n);			\
+}
+
+#  define SCAVENGE_SPEC_RBH_N_N(n)	\
+void					\
+CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \
+{					\
+    int i;				\
+    DEBUG_SCAV(n,n-1);			\
+    for(i = 0; i < n - 1; i++) {	\
+        DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN + i);    \
+    }					\
+    PROFILE_CLOSURE(Scav,n);	    	\
+    NEXT_Scav(n);			\
+}
+
+# endif
+
+SCAVENGE_SPEC_RBH_N_1(2)
+
+SCAVENGE_SPEC_RBH_N_1(3)
+SCAVENGE_SPEC_RBH_N_N(3)
+
+SCAVENGE_SPEC_RBH_N_1(4)
+SCAVENGE_SPEC_RBH_N_N(4)
+
+SCAVENGE_SPEC_RBH_N_1(5)
+SCAVENGE_SPEC_RBH_N_N(5)
+
+SCAVENGE_SPEC_RBH_N_N(6)
+SCAVENGE_SPEC_RBH_N_N(7)
+SCAVENGE_SPEC_RBH_N_N(8)
+SCAVENGE_SPEC_RBH_N_N(9)
+SCAVENGE_SPEC_RBH_N_N(10)
+SCAVENGE_SPEC_RBH_N_N(11)
+SCAVENGE_SPEC_RBH_N_N(12)
+
+#endif
+
+\end{code}
+
+\begin{code}
+
+#ifndef PAR
+/*** Malloc POINTER -- NOTHING TO SCAVENGE ***/
+
+/* (The MallocPtrList is updated at the end of GC and any unevacuated
+    MallocPtrs reported to C World)  [ADR]
+*/
+
+void
+_Scavenge_MallocPtr(STG_NO_ARGS)
+{
+    DEBUG_SCAV(MallocPtr_SIZE,0);
+    PROFILE_CLOSURE(Scav,MallocPtr_SIZE);
+    NEXT_Scav(MallocPtr_SIZE);
+    return;
+}
+#endif /* !PAR */
+
+/*** GENERAL CASE CODE ***/
+
+void
+_Scavenge_S_N(STG_NO_ARGS)
+{
+    I_ count = GEN_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs = count + GEN_CLOSURE_NoPTRS(Scav);
+		   /* Offset of last ptr word */
+    I_ size = GEN_CLOSURE_SIZE(Scav);
+
+    DEBUG_SCAV_GEN(size, GEN_CLOSURE_NoPTRS(Scav));
+
+    while (++count <= ptrs) {
+	DO_EVACUATE(Scav, count);
+    }
+    PROFILE_CLOSURE(Scav,size);
+    NEXT_Scav(size);
+    return;   
+}
+
+\end{code}
+
+The scavenge code for revertible black holes with underlying @GEN@ closures
+
+\begin{code}
+
+#ifdef PAR
+
+void
+_Scavenge_RBH_N(STG_NO_ARGS)
+{
+#if defined(GCgn)
+    P_ save_Scav;
+#endif
+
+    I_ count = GEN_RBH_HS - 1;	/* Offset of first ptr word, less 1 */
+    I_ ptrs = GEN_RBH_CLOSURE_NoPTRS(Scav);
+    I_ size = GEN_RBH_CLOSURE_SIZE(Scav);
+
+    /* 
+     * Get pointer count from original closure and adjust for one pointer 
+     * in the first two words of the RBH.
+     */
+    if (ptrs < 2)
+	ptrs = 1;
+    else
+	ptrs--;
+
+    ptrs += count;	    /* Offset of last ptr word */
+
+    DEBUG_SCAV_GEN(size, ptrs);
+
+#if defined(GCgn)
+    /* No old generation roots should be created for mutable */
+    /* pointer fields as they will be explicitly collected   */ 
+    /* Ensure this by pointing Scav at the new generation    */ 
+    save_Scav = Scav;
+    Scav = OldGen + 1;
+
+    while (++count <= ptrs) {
+	DO_EVACUATE(save_Scav, count);
+    }
+    Scav = save_Scav;
+#else
+    while (++count <= ptrs) {
+	DO_EVACUATE(Scav, count);
+    }
+#endif
+
+    PROFILE_CLOSURE(Scav,size);
+    NEXT_Scav(size);
+    return;   
+}
+
+#endif
+
+\end{code}
+
+\begin{code}
+
+/*** DYNAMIC CLOSURE -- SIZE & PTRS STORED IN CLOSURE ***/
+
+void
+_Scavenge_Dyn(STG_NO_ARGS)
+{
+    I_ count = DYN_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs = count + DYN_CLOSURE_NoPTRS(Scav);
+		   /* Offset of last ptr word */
+    I_ size = DYN_CLOSURE_SIZE(Scav);
+                           
+    DEBUG_SCAV_DYN;
+    while (++count <= ptrs) {
+	DO_EVACUATE(Scav, count);
+    }
+    PROFILE_CLOSURE(Scav,size);
+    NEXT_Scav(size);
+    return;   
+}
+
+/*** TUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
+
+void
+_Scavenge_Tuple(STG_NO_ARGS)
+{
+    I_ count = TUPLE_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs  = count + TUPLE_CLOSURE_NoPTRS(Scav);
+		   /* Offset of last ptr word */
+    I_ size  = TUPLE_CLOSURE_SIZE(Scav);
+
+    DEBUG_SCAV_TUPLE;
+    while (++count <= ptrs) {
+	DO_EVACUATE(Scav, count);
+    }
+    PROFILE_CLOSURE(Scav,size);
+    NEXT_Scav(size);
+    return;   
+}
+
+/*** DATA CLOSURE -- SIZE STORED IN CLOSURE -- NO POINTERS ***/
+
+void
+_Scavenge_Data(STG_NO_ARGS)
+{
+    I_ size = DATA_CLOSURE_SIZE(Scav);
+
+    DEBUG_SCAV_DATA;
+    PROFILE_CLOSURE(Scav,size);
+    NEXT_Scav(size);
+    return;   
+}
+
+/*** MUTUPLE CLOSURE -- ONLY PTRS STORED IN CLOSURE -- NO DATA ***/
+/*             Only if special GC treatment required           */
+
+#ifdef GC_MUT_REQUIRED
+void
+_Scavenge_MuTuple(STG_NO_ARGS)
+{
+#if defined(GCgn)
+    P_ save_Scav;
+#endif
+    I_ count = MUTUPLE_HS - 1;
+                   /* Offset of first ptr word, less 1 */
+    I_ ptrs  = count + MUTUPLE_CLOSURE_NoPTRS(Scav);
+		   /* Offset of last ptr word */
+    I_ size  = MUTUPLE_CLOSURE_SIZE(Scav);
+
+    DEBUG_SCAV_MUTUPLE;
+
+#if defined(GCgn)
+    /* No old generation roots should be created for mutable */
+    /* pointer fields as they will be explicitly collected   */ 
+    /* Ensure this by pointing Scav at the new generation    */ 
+    save_Scav = Scav;
+    Scav = OldGen + 1;
+    while (++count <= ptrs) {
+	DO_EVACUATE(save_Scav, count);
+    }
+    Scav = save_Scav;
+#else  /* GCap */
+    while (++count <= ptrs) {
+	DO_EVACUATE(Scav, count);
+    }
+#endif /* GCap */
+
+    PROFILE_CLOSURE(Scav,size);
+    NEXT_Scav(size);
+    return;   
+}
+#endif /* something generational */
+
+/*** BH CLOSURES -- NO POINTERS ***/
+
+void
+_Scavenge_BH_U(STG_NO_ARGS)
+{
+    DEBUG_SCAV_BH(BH_U_SIZE);
+    PROFILE_CLOSURE(Scav,BH_U_SIZE);
+    NEXT_Scav(BH_U_SIZE);
+    return;   
+}
+
+void
+_Scavenge_BH_N(STG_NO_ARGS)
+{
+    DEBUG_SCAV_BH(BH_N_SIZE);
+    PROFILE_CLOSURE(Scav,BH_N_SIZE);
+    NEXT_Scav(BH_N_SIZE);
+    return;   
+}
+
+/* This is needed for scavenging the indirections on the OldMutables list */
+
+void
+_Scavenge_Ind(STG_NO_ARGS)
+{
+    DEBUG_SCAV_IND;
+    PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy));
+    DO_EVACUATE(Scav, IND_HS);
+    NEXT_Scav(IND_CLOSURE_SIZE(dummy));
+    return;
+}
+
+void
+_Scavenge_Caf(STG_NO_ARGS)
+{
+    DEBUG_SCAV_IND;
+    PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy));
+    DO_EVACUATE(Scav, IND_HS);
+    NEXT_Scav(IND_CLOSURE_SIZE(dummy));
+    return;
+}
+
+#if defined(USE_COST_CENTRES)
+
+/* Special permanent indirection for lexical scoping.
+   As for _Scavenge_Ind but no PROFILE_CLOSURE.
+*/
+
+void
+_Scavenge_PI(STG_NO_ARGS)
+{
+    DEBUG_SCAV_PERM_IND;
+    /* PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy)); */
+    DO_EVACUATE(Scav, IND_HS);
+    NEXT_Scav(IND_CLOSURE_SIZE(dummy));
+    return;
+}
+#endif /* USE_COST_CENTRES */
+
+#ifdef CONCURRENT
+
+void
+_Scavenge_BQ(STG_NO_ARGS)
+{
+#if defined(GCgn)
+    P_ save_Scav;
+#endif
+
+    DEBUG_SCAV_BQ;
+
+#if defined(GCgn)
+    /* No old generation roots should be created for mutable */
+    /* pointer fields as they will be explicitly collected   */ 
+    /* Ensure this by pointing Scav at the new generation    */ 
+    save_Scav = Scav;
+    Scav = OldGen + 1;
+    DO_EVACUATE(save_Scav, BQ_HS);
+    Scav = save_Scav;
+#else  /* !GCgn */
+    DO_EVACUATE(Scav, BQ_HS);
+#endif /* GCgn */
+
+    PROFILE_CLOSURE(Scav,BQ_CLOSURE_SIZE(dummy));
+    NEXT_Scav(BQ_CLOSURE_SIZE(dummy));
+    return;   
+}
+
+void
+_Scavenge_TSO(STG_NO_ARGS)
+{
+#if defined(GCgn)
+    P_ save_Scav;
+#endif
+    STGRegisterTable *r = TSO_INTERNAL_PTR(Scav);
+    W_ liveness = r->rLiveness;
+    I_ i;
+
+    DEBUG_SCAV_TSO;
+
+#if defined(GCgn)
+    /* No old generation roots should be created for mutable */
+    /* pointer fields as they will be explicitly collected   */ 
+    /* Ensure this by pointing Scav at the new generation    */ 
+    save_Scav = Scav;
+    Scav = OldGen + 1;
+
+    DO_EVACUATE(save_Scav, TSO_LINK_LOCN);
+    DO_EVACUATE(save_Scav, ((P_) &r->rStkO) - save_Scav);
+    for(i = 0; liveness != 0; liveness >>= 1, i++) {
+    	if (liveness & 1) {
+    	    DO_EVACUATE(save_Scav, ((P_) &r->rR[i].p) - save_Scav)
+    	}
+    }
+    Scav = save_Scav;
+#else
+    DO_EVACUATE(Scav, TSO_LINK_LOCN);
+    DO_EVACUATE(Scav, ((P_) &r->rStkO) - Scav);
+    for(i = 0; liveness != 0; liveness >>= 1, i++) {
+    	if (liveness & 1) {
+    	    DO_EVACUATE(Scav, ((P_) &r->rR[i].p) - Scav)
+    	}
+    }
+#endif
+
+    PROFILE_CLOSURE(Scav, TSO_VHS + TSO_CTS_SIZE)
+    NEXT_Scav(TSO_VHS + TSO_CTS_SIZE);
+    return;
+}
+
+void
+_Scavenge_StkO(STG_NO_ARGS)
+{
+#if defined(GCgn)
+    P_ save_Scav;
+#endif
+    I_  count;
+    I_  sub = STKO_SuB_OFFSET(Scav); 	/* Offset of first update frame in B stack */
+
+    DEBUG_SCAV_STKO;
+
+#if defined(GCgn)
+    /* No old generation roots should be created for mutable */
+    /* pointer fields as they will be explicitly collected   */ 
+    /* Ensure this by pointing Scav at the new generation    */ 
+    save_Scav = Scav;
+    Scav = OldGen + 1;
+
+    /* Evacuate the link */
+    DO_EVACUATE(save_Scav, STKO_LINK_LOCN);
+
+    /* Evacuate the locations in the A stack */
+    for (count = STKO_SpA_OFFSET(save_Scav); 
+      count <= STKO_CLOSURE_CTS_SIZE(save_Scav); count++) {
+	STKO_DO_EVACUATE(count);
+    }
+
+    /* Now evacuate the updatees in the update stack */
+    while(sub > 0) {
+    	P_ subptr;
+
+    	STKO_DO_EVACUATE(sub + BREL(UF_UPDATEE));
+    	subptr = GRAB_SuB(STKO_CLOSURE_ADDR(save_Scav,sub));
+	sub = STKO_CLOSURE_OFFSET(save_Scav, subptr);
+    }
+    Scav = save_Scav;
+#else
+    /* Evacuate the link */
+    DO_EVACUATE(Scav, STKO_LINK_LOCN);
+
+    /* Evacuate the locations in the A stack */
+    for (count = STKO_SpA_OFFSET(Scav); count <= STKO_CLOSURE_CTS_SIZE(Scav); count++) {
+	STKO_DO_EVACUATE(count);
+    }
+
+    /* Now evacuate the updatees in the update stack */
+    while(sub > 0) {
+    	P_ subptr;
+
+    	STKO_DO_EVACUATE(sub + BREL(UF_UPDATEE));
+    	subptr = GRAB_SuB(STKO_CLOSURE_ADDR(Scav,sub));
+	sub = STKO_CLOSURE_OFFSET(Scav, subptr);
+    }
+#endif
+    PROFILE_CLOSURE(Scav, STKO_CLOSURE_SIZE(Scav))
+    NEXT_Scav(STKO_CLOSURE_SIZE(Scav));
+    return;
+}
+
+#ifdef PAR
+
+void
+_Scavenge_FetchMe(STG_NO_ARGS)
+{
+    DEBUG_SCAV(2,0);
+    PROFILE_CLOSURE(Scav,2);
+    NEXT_Scav(2);
+    return;
+}
+
+void
+_Scavenge_BF(STG_NO_ARGS)
+{
+#if defined(GCgn)
+    P_ save_Scav;
+#endif
+
+    DEBUG_SCAV_BF;
+
+#if defined(GCgn)
+    /* No old generation roots should be created for mutable */
+    /* pointer fields as they will be explicitly collected   */ 
+    /* Ensure this by pointing Scav at the new generation    */ 
+    save_Scav = Scav;
+    Scav = OldGen + 1;
+
+    DO_EVACUATE(save_Scav, BF_LINK_LOCN);
+    DO_EVACUATE(save_Scav, BF_NODE_LOCN);
+    Scav = save_Scav;
+#else
+    DO_EVACUATE(Scav, BF_LINK_LOCN);
+    DO_EVACUATE(Scav, BF_NODE_LOCN);
+#endif
+
+    PROFILE_CLOSURE(Scav, BF_CLOSURE_SIZE(dummy))
+    NEXT_Scav(BF_CLOSURE_SIZE(dummy));
+    return;
+}
+
+#endif  /* PAR */
+#endif	/* CONCURRENT */
+
+#if defined(GCgn)
+
+/* Recently allocated old roots for promoted objects refernecing
+   the new generation will be scavenged -- Just move to the next
+*/
+
+void
+_Scavenge_OldRoot(STG_NO_ARGS)
+{
+    DEBUG_SCAV_OLDROOT(MIN_UPD_SIZE); /* dodgy size (WDP 95/07) */
+    NEXT_Scav(MIN_UPD_SIZE);
+    return;
+}
+
+P_
+_Evacuate_OldRoot(evac)
+P_ evac;
+{
+    fprintf(stderr,"Called _Evacuate_OldRoot: Closure %lx Info %lx\nShould never occur!\n",
+	    (W_) evac, (W_) INFO_PTR(evac));
+    abort();
+}
+
+#endif /* GCgn */
+
+void
+_Scavenge_Forward_Ref(STG_NO_ARGS)
+{
+    fprintf(stderr,"Called _Scavenge_Forward_Ref: Closure %lx Info %lx\nShould never occur!\n",
+	    (W_) Scav, (W_) INFO_PTR(Scav));
+    abort();
+}
+
+
+#endif /* _INFO_COPYING */
+
+\end{code}
diff --git a/ghc/runtime/storage/SMstacks.lc b/ghc/runtime/storage/SMstacks.lc
new file mode 100644
index 0000000000..dc7452b027
--- /dev/null
+++ b/ghc/runtime/storage/SMstacks.lc
@@ -0,0 +1,57 @@
+\section[SMstacks.lc]{Stack allocation (sequential)}
+
+Routine that allocates the A and B stack (sequential only).
+
+\begin{code}
+#ifndef PAR
+# define NULL_REG_MAP
+# include "SMinternal.h"
+
+stackData stackInfo;
+
+P_ stks_space = 0;
+
+#ifdef CONCURRENT
+EXTDATA_RO(StkO_static_info);
+P_ MainStkO;
+#endif
+
+I_
+initStacks(sm)
+smInfo *sm;
+{
+    /*
+     * Allocate them if they don't exist. One space does for both stacks, since they
+     * grow towards each other
+     */
+    if (stks_space == 0) {
+#ifdef CONCURRENT
+	MainStkO = (P_) xmalloc((STKO_HS + SM_word_stk_size) * sizeof(W_));
+	stks_space = MainStkO + STKO_HS;
+        SET_STKO_HDR(MainStkO, StkO_static_info, CC_SUBSUMED);
+        STKO_SIZE(MainStkO) = SM_word_stk_size + STKO_VHS;
+        STKO_LINK(MainStkO) = Nil_closure;
+    	STKO_RETURN(MainStkO) = NULL;
+#else
+	stks_space = (P_) xmalloc(SM_word_stk_size * sizeof(W_));
+#endif
+    }
+# if STACK_CHECK_BY_PAGE_FAULT
+    unmapMiddleStackPage((char *) stks_space, SM_word_stk_size * sizeof(W_));
+# endif
+
+    /* Initialise Stack Info and pointers */
+    stackInfo.botA = STK_A_FRAME_BASE(stks_space, SM_word_stk_size);
+    stackInfo.botB = STK_B_FRAME_BASE(stks_space, SM_word_stk_size);
+
+    MAIN_SuA = MAIN_SpA = stackInfo.botA + AREL(1);
+    MAIN_SuB = MAIN_SpB = stackInfo.botB + BREL(1);
+
+    if (SM_trace)
+	fprintf(stderr, "STACK init: botA, spa: 0x%lx, 0x%lx\n            botB, spb: 0x%lx, 0x%lx\n",
+	  (W_) stackInfo.botA, (W_) MAIN_SpA, (W_) stackInfo.botB, (W_) MAIN_SpB);
+
+    return 0;
+}
+#endif /* not parallel */
+\end{code}
diff --git a/ghc/runtime/storage/SMstatic.lc b/ghc/runtime/storage/SMstatic.lc
new file mode 100644
index 0000000000..2f953f135a
--- /dev/null
+++ b/ghc/runtime/storage/SMstatic.lc
@@ -0,0 +1,322 @@
+***************************************************************************
+
+    STATIC closures -- INTLIKE and CHARLIKE stuff.
+
+***************************************************************************
+
+@CZh_entry@, @CZh_static_info@, @IZh_entry@ and @IZh_static_info@ 
+are built by the compiler from {\tr uTys.hs}.
+
+\begin{code}
+#define NULL_REG_MAP
+#include "SMinternal.h"
+
+EXTDATA_RO(CZh_static_info);
+
+#define __CHARLIKE_CLOSURE(n) (CHARLIKE_closures+((n)*(CHARLIKE_HS+1)))
+#define __INTLIKE_CLOSURE(n)  (INTLIKE_closures_def+(((n)-MIN_INTLIKE)*(INTLIKE_HS+1)))
+
+#define CHARLIKE_HDR(n)	    SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),CZh_static_info,CC_DONTZuCARE), (W_) n
+
+#define INTLIKE_HDR(n)	    SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),IZh_static_info,CC_DONTZuCARE), (W_) n
+
+const W_ CHARLIKE_closures[] = {
+    CHARLIKE_HDR(0),
+    CHARLIKE_HDR(1),
+    CHARLIKE_HDR(2),
+    CHARLIKE_HDR(3),
+    CHARLIKE_HDR(4),
+    CHARLIKE_HDR(5),
+    CHARLIKE_HDR(6),
+    CHARLIKE_HDR(7),
+    CHARLIKE_HDR(8),
+    CHARLIKE_HDR(9),
+    CHARLIKE_HDR(10),
+    CHARLIKE_HDR(11),
+    CHARLIKE_HDR(12),
+    CHARLIKE_HDR(13),
+    CHARLIKE_HDR(14),
+    CHARLIKE_HDR(15),
+    CHARLIKE_HDR(16),
+    CHARLIKE_HDR(17),
+    CHARLIKE_HDR(18),
+    CHARLIKE_HDR(19),
+    CHARLIKE_HDR(20),
+    CHARLIKE_HDR(21),
+    CHARLIKE_HDR(22),
+    CHARLIKE_HDR(23),
+    CHARLIKE_HDR(24),
+    CHARLIKE_HDR(25),
+    CHARLIKE_HDR(26),
+    CHARLIKE_HDR(27),
+    CHARLIKE_HDR(28),
+    CHARLIKE_HDR(29),
+    CHARLIKE_HDR(30),
+    CHARLIKE_HDR(31),
+    CHARLIKE_HDR(32),
+    CHARLIKE_HDR(33),
+    CHARLIKE_HDR(34),
+    CHARLIKE_HDR(35),
+    CHARLIKE_HDR(36),
+    CHARLIKE_HDR(37),
+    CHARLIKE_HDR(38),
+    CHARLIKE_HDR(39),
+    CHARLIKE_HDR(40),
+    CHARLIKE_HDR(41),
+    CHARLIKE_HDR(42),
+    CHARLIKE_HDR(43),
+    CHARLIKE_HDR(44),
+    CHARLIKE_HDR(45),
+    CHARLIKE_HDR(46),
+    CHARLIKE_HDR(47),
+    CHARLIKE_HDR(48),
+    CHARLIKE_HDR(49),
+    CHARLIKE_HDR(50),
+    CHARLIKE_HDR(51),
+    CHARLIKE_HDR(52),
+    CHARLIKE_HDR(53),
+    CHARLIKE_HDR(54),
+    CHARLIKE_HDR(55),
+    CHARLIKE_HDR(56),
+    CHARLIKE_HDR(57),
+    CHARLIKE_HDR(58),
+    CHARLIKE_HDR(59),
+    CHARLIKE_HDR(60),
+    CHARLIKE_HDR(61),
+    CHARLIKE_HDR(62),
+    CHARLIKE_HDR(63),
+    CHARLIKE_HDR(64),
+    CHARLIKE_HDR(65),
+    CHARLIKE_HDR(66),
+    CHARLIKE_HDR(67),
+    CHARLIKE_HDR(68),
+    CHARLIKE_HDR(69),
+    CHARLIKE_HDR(70),
+    CHARLIKE_HDR(71),
+    CHARLIKE_HDR(72),
+    CHARLIKE_HDR(73),
+    CHARLIKE_HDR(74),
+    CHARLIKE_HDR(75),
+    CHARLIKE_HDR(76),
+    CHARLIKE_HDR(77),
+    CHARLIKE_HDR(78),
+    CHARLIKE_HDR(79),
+    CHARLIKE_HDR(80),
+    CHARLIKE_HDR(81),
+    CHARLIKE_HDR(82),
+    CHARLIKE_HDR(83),
+    CHARLIKE_HDR(84),
+    CHARLIKE_HDR(85),
+    CHARLIKE_HDR(86),
+    CHARLIKE_HDR(87),
+    CHARLIKE_HDR(88),
+    CHARLIKE_HDR(89),
+    CHARLIKE_HDR(90),
+    CHARLIKE_HDR(91),
+    CHARLIKE_HDR(92),
+    CHARLIKE_HDR(93),
+    CHARLIKE_HDR(94),
+    CHARLIKE_HDR(95),
+    CHARLIKE_HDR(96),
+    CHARLIKE_HDR(97),
+    CHARLIKE_HDR(98),
+    CHARLIKE_HDR(99),
+    CHARLIKE_HDR(100),
+    CHARLIKE_HDR(101),
+    CHARLIKE_HDR(102),
+    CHARLIKE_HDR(103),
+    CHARLIKE_HDR(104),
+    CHARLIKE_HDR(105),
+    CHARLIKE_HDR(106),
+    CHARLIKE_HDR(107),
+    CHARLIKE_HDR(108),
+    CHARLIKE_HDR(109),
+    CHARLIKE_HDR(110),
+    CHARLIKE_HDR(111),
+    CHARLIKE_HDR(112),
+    CHARLIKE_HDR(113),
+    CHARLIKE_HDR(114),
+    CHARLIKE_HDR(115),
+    CHARLIKE_HDR(116),
+    CHARLIKE_HDR(117),
+    CHARLIKE_HDR(118),
+    CHARLIKE_HDR(119),
+    CHARLIKE_HDR(120),
+    CHARLIKE_HDR(121),
+    CHARLIKE_HDR(122),
+    CHARLIKE_HDR(123),
+    CHARLIKE_HDR(124),
+    CHARLIKE_HDR(125),
+    CHARLIKE_HDR(126),
+    CHARLIKE_HDR(127),
+    CHARLIKE_HDR(128),
+    CHARLIKE_HDR(129),
+    CHARLIKE_HDR(130),
+    CHARLIKE_HDR(131),
+    CHARLIKE_HDR(132),
+    CHARLIKE_HDR(133),
+    CHARLIKE_HDR(134),
+    CHARLIKE_HDR(135),
+    CHARLIKE_HDR(136),
+    CHARLIKE_HDR(137),
+    CHARLIKE_HDR(138),
+    CHARLIKE_HDR(139),
+    CHARLIKE_HDR(140),
+    CHARLIKE_HDR(141),
+    CHARLIKE_HDR(142),
+    CHARLIKE_HDR(143),
+    CHARLIKE_HDR(144),
+    CHARLIKE_HDR(145),
+    CHARLIKE_HDR(146),
+    CHARLIKE_HDR(147),
+    CHARLIKE_HDR(148),
+    CHARLIKE_HDR(149),
+    CHARLIKE_HDR(150),
+    CHARLIKE_HDR(151),
+    CHARLIKE_HDR(152),
+    CHARLIKE_HDR(153),
+    CHARLIKE_HDR(154),
+    CHARLIKE_HDR(155),
+    CHARLIKE_HDR(156),
+    CHARLIKE_HDR(157),
+    CHARLIKE_HDR(158),
+    CHARLIKE_HDR(159),
+    CHARLIKE_HDR(160),
+    CHARLIKE_HDR(161),
+    CHARLIKE_HDR(162),
+    CHARLIKE_HDR(163),
+    CHARLIKE_HDR(164),
+    CHARLIKE_HDR(165),
+    CHARLIKE_HDR(166),
+    CHARLIKE_HDR(167),
+    CHARLIKE_HDR(168),
+    CHARLIKE_HDR(169),
+    CHARLIKE_HDR(170),
+    CHARLIKE_HDR(171),
+    CHARLIKE_HDR(172),
+    CHARLIKE_HDR(173),
+    CHARLIKE_HDR(174),
+    CHARLIKE_HDR(175),
+    CHARLIKE_HDR(176),
+    CHARLIKE_HDR(177),
+    CHARLIKE_HDR(178),
+    CHARLIKE_HDR(179),
+    CHARLIKE_HDR(180),
+    CHARLIKE_HDR(181),
+    CHARLIKE_HDR(182),
+    CHARLIKE_HDR(183),
+    CHARLIKE_HDR(184),
+    CHARLIKE_HDR(185),
+    CHARLIKE_HDR(186),
+    CHARLIKE_HDR(187),
+    CHARLIKE_HDR(188),
+    CHARLIKE_HDR(189),
+    CHARLIKE_HDR(190),
+    CHARLIKE_HDR(191),
+    CHARLIKE_HDR(192),
+    CHARLIKE_HDR(193),
+    CHARLIKE_HDR(194),
+    CHARLIKE_HDR(195),
+    CHARLIKE_HDR(196),
+    CHARLIKE_HDR(197),
+    CHARLIKE_HDR(198),
+    CHARLIKE_HDR(199),
+    CHARLIKE_HDR(200),
+    CHARLIKE_HDR(201),
+    CHARLIKE_HDR(202),
+    CHARLIKE_HDR(203),
+    CHARLIKE_HDR(204),
+    CHARLIKE_HDR(205),
+    CHARLIKE_HDR(206),
+    CHARLIKE_HDR(207),
+    CHARLIKE_HDR(208),
+    CHARLIKE_HDR(209),
+    CHARLIKE_HDR(210),
+    CHARLIKE_HDR(211),
+    CHARLIKE_HDR(212),
+    CHARLIKE_HDR(213),
+    CHARLIKE_HDR(214),
+    CHARLIKE_HDR(215),
+    CHARLIKE_HDR(216),
+    CHARLIKE_HDR(217),
+    CHARLIKE_HDR(218),
+    CHARLIKE_HDR(219),
+    CHARLIKE_HDR(220),
+    CHARLIKE_HDR(221),
+    CHARLIKE_HDR(222),
+    CHARLIKE_HDR(223),
+    CHARLIKE_HDR(224),
+    CHARLIKE_HDR(225),
+    CHARLIKE_HDR(226),
+    CHARLIKE_HDR(227),
+    CHARLIKE_HDR(228),
+    CHARLIKE_HDR(229),
+    CHARLIKE_HDR(230),
+    CHARLIKE_HDR(231),
+    CHARLIKE_HDR(232),
+    CHARLIKE_HDR(233),
+    CHARLIKE_HDR(234),
+    CHARLIKE_HDR(235),
+    CHARLIKE_HDR(236),
+    CHARLIKE_HDR(237),
+    CHARLIKE_HDR(238),
+    CHARLIKE_HDR(239),
+    CHARLIKE_HDR(240),
+    CHARLIKE_HDR(241),
+    CHARLIKE_HDR(242),
+    CHARLIKE_HDR(243),
+    CHARLIKE_HDR(244),
+    CHARLIKE_HDR(245),
+    CHARLIKE_HDR(246),
+    CHARLIKE_HDR(247),
+    CHARLIKE_HDR(248),
+    CHARLIKE_HDR(249),
+    CHARLIKE_HDR(250),
+    CHARLIKE_HDR(251),
+    CHARLIKE_HDR(252),
+    CHARLIKE_HDR(253),
+    CHARLIKE_HDR(254),
+    CHARLIKE_HDR(255)
+};
+
+EXTDATA_RO(IZh_static_info);
+
+static const W_ INTLIKE_closures_def[] = {
+    INTLIKE_HDR(-16),	/* MIN_INTLIKE == -16 */
+    INTLIKE_HDR(-15),
+    INTLIKE_HDR(-14),
+    INTLIKE_HDR(-13),
+    INTLIKE_HDR(-12),
+    INTLIKE_HDR(-11),
+    INTLIKE_HDR(-10),
+    INTLIKE_HDR(-9),
+    INTLIKE_HDR(-8),
+    INTLIKE_HDR(-7),
+    INTLIKE_HDR(-6),
+    INTLIKE_HDR(-5),
+    INTLIKE_HDR(-4),
+    INTLIKE_HDR(-3),
+    INTLIKE_HDR(-2),
+    INTLIKE_HDR(-1),
+    INTLIKE_HDR(0),
+    INTLIKE_HDR(1),
+    INTLIKE_HDR(2),
+    INTLIKE_HDR(3),
+    INTLIKE_HDR(4),
+    INTLIKE_HDR(5),
+    INTLIKE_HDR(6),
+    INTLIKE_HDR(7),
+    INTLIKE_HDR(8),
+    INTLIKE_HDR(9),
+    INTLIKE_HDR(10),
+    INTLIKE_HDR(11),
+    INTLIKE_HDR(12),
+    INTLIKE_HDR(13),
+    INTLIKE_HDR(14),
+    INTLIKE_HDR(15),
+    INTLIKE_HDR(16)	/* MAX_INTLIKE == 16 */
+};
+
+P_ INTLIKE_closures = (P_) __INTLIKE_CLOSURE(0);
+
+\end{code}
diff --git a/ghc/runtime/storage/SMstats.lc b/ghc/runtime/storage/SMstats.lc
new file mode 100644
index 0000000000..3f6dfc3d60
--- /dev/null
+++ b/ghc/runtime/storage/SMstats.lc
@@ -0,0 +1,468 @@
+*********************************************************************
+
+                 Stuff for printing out GC statistics
+
+usertime()    -- The current user time in seconds
+elapsedtime() -- The current elapsed time in seconds
+
+stat_init
+stat_startGC
+stat_endGC
+stat_exit
+
+*********************************************************************
+
+\begin{code}
+#ifdef hpux_TARGET_OS
+#define _INCLUDE_HPUX_SOURCE
+#endif
+
+#define NULL_REG_MAP
+#include "SMinternal.h"
+#include "RednCounts.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TIMES_H
+#include <sys/times.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
+#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS
+#include <sys/resource.h>
+#endif
+
+#ifdef HAVE_SYS_TIMEB_H
+#include <sys/timeb.h>
+#endif
+
+#ifdef hpux_TARGET_OS
+#include <sys/syscall.h>
+#define getrusage(a, b)  syscall(SYS_GETRUSAGE, a, b)
+#define HAVE_GETRUSAGE
+#endif
+
+static StgDouble GC_start_time,  GC_tot_time = 0;  /* User GC Time */
+static StgDouble GCe_start_time, GCe_tot_time = 0; /* Elapsed GC time */
+
+#if defined(GCap) || defined(GCgn)
+static StgDouble GC_min_time = 0;
+static StgDouble GCe_min_time = 0;
+
+static I_ GC_min_no = 0;
+static I_ GC_min_since_maj = 0;
+static I_ GC_live_maj = 0;         /* Heap live at last major collection */
+static I_ GC_alloc_since_maj = 0;  /* Heap alloc since collection major */
+#endif
+
+static I_ GC_maj_no = 0;
+static ullong GC_tot_alloc = 0;        /* Total heap allocated -- 64 bits? */
+
+static I_ GC_start_faults = 0, GC_end_faults = 0;
+
+char *
+#ifdef __STDC__ 
+ullong_format_string(ullong x, char *s, rtsBool with_commas)
+#else
+ullong_format_string(x, s, with_commas)
+    ullong x;
+    char  *s;
+    rtsBool with_commas;
+#endif
+{
+    if (x < (ullong)1000) 
+	sprintf(s, "%ld", (I_)x);
+    else if (x < (ullong)1000000)
+	sprintf(s, (with_commas) ? "%ld,%3.3ld" : "%ld%3.3ld",
+		(I_)((x)/(ullong)1000),
+		(I_)((x)%(ullong)1000));
+    else if (x < (ullong)1000000000)
+	sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld" :  "%ld%3.3ld%3.3ld",
+		(I_)((x)/(ullong)1000000),
+		(I_)((x)/(ullong)1000%(ullong)1000),
+		(I_)((x)%(ullong)1000));
+    else
+	sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld%3.3ld",
+		(I_)((x)/(ullong)1000000000),
+		(I_)((x)/(ullong)1000000%(ullong)1000),
+		(I_)((x)/(ullong)1000%(ullong)1000), 
+		(I_)((x)%(ullong)1000));
+    return s;
+}
+
+/* "constants" for "usertime" and "elapsedtime" */
+
+static StgDouble ElapsedTimeStart = 0.0; /* setup when beginning things */
+static StgDouble TicksPerSecond   = 0.0; /* ditto */
+
+/* usertime() -- The current user time in seconds */
+
+StgDouble
+usertime()
+{
+#if ! (defined(HAVE_GETRUSAGE) || defined(HAVE_TIMES))
+    /* We will #ifdef around the fprintf for machines
+       we *know* are unsupported. (WDP 94/05)
+    */
+    fprintf(stderr, "NOTE: `usertime' does nothing!\n");
+    return 0.0;
+
+#else /* not stumped */
+
+/* "times" is the more standard, but we prefer "getrusage"
+    (because we are old worn-out BSD hackers)
+*/
+# if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS
+    struct rusage t;
+
+    getrusage(RUSAGE_SELF, &t);
+    return(t.ru_utime.tv_sec + 1e-6*t.ru_utime.tv_usec);
+
+# else /* HAVE_TIMES */
+    struct tms t;
+
+    times(&t);
+    return(((StgDouble)(t.tms_utime))/TicksPerSecond);
+
+# endif /* HAVE_TIMES */
+#endif /* not stumped */
+}
+
+
+/* elapsedtime() -- The current elapsed time in seconds */
+
+StgDouble
+elapsedtime()
+{
+#if ! (defined(HAVE_TIMES) || defined(HAVE_FTIME))
+    /* We will #ifdef around the fprintf for machines
+       we *know* are unsupported. (WDP 94/05)
+    */
+    fprintf(stderr, "NOTE: `elapsedtime' does nothing!\n");
+    return 0.0;
+
+#else /* not stumped */
+
+/* "ftime" may be nicer, but "times" is more standard;
+   but, on a Sun, if you do not get the SysV one, you are *hosed*...
+ */
+
+# if defined(HAVE_TIMES) && ! sunos4_TARGET_OS
+    struct tms t;
+
+    return (((StgDouble) times(&t))/TicksPerSecond - ElapsedTimeStart);
+
+# else /* HAVE_FTIME */
+    struct timeb t;
+
+    ftime(&t);
+    return t.time + 1e-3*t.millitm - ElapsedTimeStart;
+
+# endif /* HAVE_FTIME */
+#endif /* not stumped */
+}
+
+void
+start_time(STG_NO_ARGS)
+{
+    long ticks;
+
+    /* Determine TicksPerSecond ... */
+#ifdef HAVE_SYSCONF
+    ticks = sysconf(_SC_CLK_TCK);
+    if ( ticks == -1 ) {
+	fprintf(stderr, "stat_init: bad call to 'sysconf'!\n");
+    	EXIT(EXIT_FAILURE);
+    }
+    TicksPerSecond = (StgDouble) ticks;
+
+#else /* no "sysconf"; had better guess */
+# ifdef HZ
+    TicksPerSecond = (StgDouble) (HZ);
+
+# else /* had better guess wildly */
+    /* We will #ifdef around the fprintf for machines
+       we *know* are unsupported. (WDP 94/05)
+    */
+    fprintf(stderr, "NOTE: Guessing `TicksPerSecond = 60'!\n");
+    TicksPerSecond = 60.0;
+    return;
+# endif
+#endif
+    ElapsedTimeStart = elapsedtime();
+}
+
+static StgDouble InitUserTime = 0.0; /* user time taken for initialization */
+static StgDouble InitElapsedTime = 0.0; /* elapsed time taken for initialization */
+
+void end_init(STG_NO_ARGS)
+{
+    InitUserTime = usertime();
+    InitElapsedTime = elapsedtime();
+}
+
+static I_
+pagefaults(STG_NO_ARGS)
+{
+#if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS
+    return 0;
+#else
+    struct rusage t;
+
+    getrusage(RUSAGE_SELF, &t);
+    return(t.ru_majflt);
+#endif
+}
+
+/* Called at the beginning of execution of the program */
+/* Writes the command line and inits stats header */
+
+void stat_init(collector, comment1, comment2)
+char *collector, *comment1, *comment2;
+{
+    if (SM_statsfile != NULL) {
+	char temp[BIG_STRING_LEN];
+	ullong_format_string( (ullong)SM_word_heap_size*sizeof(W_), temp, rtsTrue/*commas*/);
+	fprintf(SM_statsfile, "\nCollector: %s  HeapSize: %s (bytes)\n\n", collector, temp);
+	if (SM_stats_verbose) {
+#if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS
+	    fprintf(SM_statsfile, "NOTE: `pagefaults' does nothing!\n");
+#endif
+	    fprintf(SM_statsfile,
+/*######## ####### #######  ##.#  ##.## ##.## ####.## ####.## #### ####*/
+ "  Alloc  Collect   Live   Resid   GC    GC     TOT     TOT  Page Flts  %s\n",
+		    comment1);
+	    fprintf(SM_statsfile,
+ "  bytes   bytes    bytes   ency  user  elap    user    elap   GC  MUT  %s\n",
+		    comment2);
+	}
+
+#if defined(GCap) || defined(GCgn)
+        else {
+	    fprintf(SM_statsfile,
+/*######## #######  ##.#  #######  ##.#   ###  ##.## ##.## ##.## ##.## ####.## ####.## #### ####*/
+ "  Alloc  Promote  Promo   Live   Resid Minor Minor Minor Major Major    TOT     TOT  Page Flts\n");
+	    fprintf(SM_statsfile,
+ "  bytes   bytes    ted    bytes   ency   No   user  elap  user  elap    user    elap  MUT Major\n");
+	}
+#endif /* generational */
+
+	fflush(SM_statsfile);
+    }
+}
+
+
+/* Called at the beginning of each GC */
+static I_ rub_bell = 0;
+
+void
+stat_startGC(alloc)
+  I_ alloc;
+{
+#if defined(GCap) || defined(GCgn)
+    I_ bell = alloc == 0 ? SM_ring_bell : 0;
+#else  /* ! generational */
+    I_ bell = SM_ring_bell;
+#endif /* ! generational */
+
+    if (bell) {
+	if (bell > 1) {
+	    fprintf(stderr, " GC ");
+	    rub_bell = 1;
+	} else {
+	    fprintf(stderr, "\007");
+	}
+    }
+
+    if (SM_statsfile != NULL) {
+	GC_start_time = usertime();
+	GCe_start_time = elapsedtime();
+	
+#if defined(GCap) || defined(GCgn)
+        if (SM_stats_verbose || alloc == 0) {
+	    GC_start_faults = pagefaults();
+	}
+#else  /* ! generational */
+	if (SM_stats_verbose) {
+	    GC_start_faults = pagefaults();
+	}
+#endif /* ! generational */
+
+    }
+}
+
+
+/* Called at the end of each GC */
+
+void
+stat_endGC(alloc, collect, live, comment)
+  I_ alloc, collect, live;
+  char *comment;
+{
+    if (SM_statsfile != NULL) {
+	StgDouble time = usertime();
+	StgDouble etime = elapsedtime();
+
+	if (SM_stats_verbose){
+	    I_ faults = pagefaults();
+
+	    fprintf(SM_statsfile, "%8ld %7ld %7ld %5.1f%%",
+		    alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_), collect == 0 ? 0.0 : (live / (StgFloat) collect * 100));
+	    fprintf(SM_statsfile, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld  %s\n", 
+		    (time-GC_start_time), 
+		    (etime-GCe_start_time), 
+		    time,
+		    etime,
+		    faults - GC_start_faults,
+		    GC_start_faults - GC_end_faults,
+		    comment);
+
+	    GC_end_faults = faults;
+	    fflush(SM_statsfile);
+	}
+
+#if defined(GCap) || defined(GCgn)
+        else if(alloc == 0 && collect != 0) {
+	    I_ faults = pagefaults();
+
+	    fprintf(SM_statsfile, "%8ld %7ld %5.1f%% %7ld %5.1f%%",
+		    GC_alloc_since_maj*sizeof(W_), (collect - GC_live_maj)*sizeof(W_),
+		    (collect - GC_live_maj) / (StgFloat) GC_alloc_since_maj * 100,
+		    live*sizeof(W_), live / (StgFloat) SM_word_heap_size * 100);
+	    fprintf(SM_statsfile, "  %3ld  %5.2f %5.2f %5.2f %5.2f %7.2f %7.2f %4ld %4ld\n",
+		    GC_min_since_maj, GC_min_time, GCe_min_time,
+		    (time-GC_start_time), 
+		    (etime-GCe_start_time), 
+		    time,
+		    etime,
+		    faults - GC_start_faults,
+		    GC_start_faults - GC_end_faults
+		    );
+
+	    GC_end_faults = faults;
+	    fflush(SM_statsfile);
+	}
+#endif /* generational */
+
+#if defined(GCap) || defined(GCgn)
+	if (alloc == 0 && collect != 0) {
+	    GC_maj_no++;
+	    GC_live_maj = live;
+	    GC_min_no += GC_min_since_maj;
+	    GC_min_since_maj = 0;
+	    GC_tot_alloc += (ullong) GC_alloc_since_maj;
+	    GC_alloc_since_maj = 0;
+	    GC_tot_time  += time-GC_start_time + GC_min_time;
+	    GC_min_time = 0;
+	    GCe_tot_time += etime-GCe_start_time + GCe_min_time;
+	    GCe_min_time = 0;
+	} else {
+	    GC_min_since_maj++;
+	    GC_alloc_since_maj += alloc;
+	    GC_min_time += time-GC_start_time;
+	    GCe_min_time += etime-GCe_start_time;
+	}
+#else /* ! generational */
+	GC_maj_no++;
+	GC_tot_alloc += (ullong) alloc;
+	GC_tot_time  += time-GC_start_time;
+	GCe_tot_time += etime-GCe_start_time;
+#endif /* ! generational */
+
+    }
+
+    if (rub_bell) {
+	fprintf(stderr, "\b\b\b  \b\b\b");
+	rub_bell = 0;
+    }
+}
+
+
+/* Called at the end of execution -- to print a summary of statistics */
+
+void
+stat_exit(alloc)
+  I_ alloc;
+{
+    if (SM_statsfile != NULL){
+	char temp[BIG_STRING_LEN];
+	StgDouble time = usertime();
+	StgDouble etime = elapsedtime();
+
+	if (SM_stats_verbose) {
+	    fprintf(SM_statsfile, "%8ld\n\n", alloc*sizeof(W_));
+	}
+
+#if defined(GCap) || defined (GCgn)
+	else {
+	    fprintf(SM_statsfile, "%8ld %7.7s %6.6s %7.7s %6.6s",
+		    (GC_alloc_since_maj + alloc)*sizeof(W_), "", "", "", "");
+	    fprintf(SM_statsfile, "  %3ld  %5.2f %5.2f\n\n",
+		    GC_min_since_maj, GC_min_time, GCe_min_time);
+	}
+	GC_min_no    += GC_min_since_maj;
+	GC_tot_time  += GC_min_time;
+	GCe_tot_time += GCe_min_time;
+	GC_tot_alloc += (ullong) (GC_alloc_since_maj + alloc);
+	ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
+	fprintf(SM_statsfile, "%11s bytes allocated in the heap\n", temp);
+	if ( ResidencySamples > 0 ) {
+	    ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
+	    fprintf(SM_statsfile, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
+			      temp,
+			      MaxResidency / (StgFloat) SM_word_heap_size * 100,
+			      ResidencySamples);
+	}
+	fprintf(SM_statsfile, "%11ld garbage collections performed (%ld major, %ld minor)\n\n",
+		GC_maj_no + GC_min_no, GC_maj_no, GC_min_no);
+
+#else  /* ! generational */
+
+	GC_tot_alloc += (ullong) alloc;
+	ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
+	fprintf(SM_statsfile, "%11s bytes allocated in the heap\n", temp);
+	if ( ResidencySamples > 0 ) {
+	    ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
+	    fprintf(SM_statsfile, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
+			      temp,
+			      MaxResidency / (StgFloat) SM_word_heap_size * 100,
+			      ResidencySamples);
+	}
+	fprintf(SM_statsfile, "%11ld garbage collections performed\n\n", GC_maj_no);
+
+#endif /* ! generational */
+
+	fprintf(SM_statsfile, "  INIT  time  %6.2fs  (%6.2fs elapsed)\n",
+		InitUserTime, InitElapsedTime);
+	fprintf(SM_statsfile, "  MUT   time  %6.2fs  (%6.2fs elapsed)\n",
+		time - GC_tot_time - InitUserTime, 
+                etime - GCe_tot_time - InitElapsedTime);
+	fprintf(SM_statsfile, "  GC    time  %6.2fs  (%6.2fs elapsed)\n",
+		GC_tot_time, GCe_tot_time);
+	fprintf(SM_statsfile, "  Total time  %6.2fs  (%6.2fs elapsed)\n\n",
+		time, etime);
+
+	fprintf(SM_statsfile, "  %%GC time     %5.1f%%  (%.1f%% elapsed)\n\n",
+		GC_tot_time*100./time, GCe_tot_time*100./etime);
+
+	ullong_format_string((ullong)(GC_tot_alloc*sizeof(W_)/(time - GC_tot_time)), temp, rtsTrue/*commas*/);
+	fprintf(SM_statsfile, "  Alloc rate    %s bytes per MUT second\n\n", temp);
+
+	fprintf(SM_statsfile, "  Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n",
+		(time - GC_tot_time - InitUserTime) * 100. / time, 
+                (time - GC_tot_time - InitUserTime) * 100. / etime);
+	fflush(SM_statsfile);
+	fclose(SM_statsfile);
+    }
+}
+
+\end{code}
diff --git a/ghc/runtime/storage/mprotect.lc b/ghc/runtime/storage/mprotect.lc
new file mode 100644
index 0000000000..8c50a6ee5a
--- /dev/null
+++ b/ghc/runtime/storage/mprotect.lc
@@ -0,0 +1,78 @@
+%
+% (c) The AQUA Project, Glasgow University, 1995
+%
+%************************************************************************
+%*                                                                      *
+\section[mprotect.lc]{Memory Protection}
+%*									*
+%************************************************************************
+
+Is @mprotect@ POSIX now?
+
+\begin{code}
+
+#if STACK_CHECK_BY_PAGE_FAULT
+
+/* #define STK_CHK_DEBUG */
+
+#include "rtsdefs.h"
+
+# ifdef HAVE_SYS_TYPES_H
+#  include <sys/types.h>
+# endif
+
+# ifdef HAVE_SYS_MMAN_H
+#  include <sys/mman.h>
+# endif
+
+# if defined(_SC_PAGE_SIZE) && !defined(_SC_PAGESIZE)
+    /* Death to HP-UX.  What are standards for, anyway??? */
+#  define _SC_PAGESIZE _SC_PAGE_SIZE
+# endif
+
+# if defined(_SC_PAGESIZE)
+#  define GETPAGESIZE()	sysconf(_SC_PAGESIZE)
+# else
+#  if defined(HAVE_GETPAGESIZE)
+#   define GETPAGESIZE()    getpagesize()
+#  else
+#   error getpagesize
+#  endif
+# endif
+
+#if defined(sunos4_TARGET_OS)
+extern int getpagesize PROTO((void));
+extern int mprotect PROTO((caddr_t, size_t, int));
+#endif
+
+void 
+unmapMiddleStackPage(addr_, size)
+char * /*caddr_t*/ addr_;
+int size;
+{
+    int pagesize = GETPAGESIZE();
+    caddr_t addr = addr_;
+    caddr_t middle = (caddr_t) (((W_) (addr + size / 2)) / pagesize * pagesize);
+
+# ifdef STK_CHK_DEBUG
+    fprintf(stderr, "pagesize: %x\nstack start: %08lx\nstack size: %08lx\nstack middle: %08lx\n",
+      pagesize, addr, size, middle);
+# endif
+
+    if (middle < addr || middle + pagesize > addr + size) {
+	fprintf(stderr, "Stack too small; stack overflow trap disabled.\n");
+	return;
+    }
+    if (mprotect(middle, pagesize, PROT_NONE) == -1) {
+	perror("mprotect");
+	exit(1);
+    }
+    if (install_segv_handler()) {
+	fprintf(stderr, "Can't install SIGSEGV handler for stack overflow check.\n");
+	EXIT(EXIT_FAILURE);
+    }
+}
+
+#endif /* STACK_CHECK_BY_PAGE_FAULT */
+
+\end{code}