diff --git a/mps/src/mpm.h b/mps/src/mpm.h
index 3007877a451..58be405da2d 100644
--- a/mps/src/mpm.h
+++ b/mps/src/mpm.h
@@ -1,6 +1,6 @@
 /* impl.h.mpm: MEMORY POOL MANAGER DEFINITIONS
  *
- * $HopeName: MMsrc!mpm.h(trunk.43) $
+ * $HopeName: MMsrc!mpm.h(trunk.44) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  */
 
@@ -271,6 +271,7 @@ extern void PoolFree(Pool pool, Addr old, Size size);
 extern Res PoolTraceBegin(Pool pool, Trace trace, Action action);
 extern Res PoolCondemn(Pool pool, Trace trace, Seg seg, Action action);
 extern void PoolGrey(Pool pool, Trace trace, Seg seg);
+extern void PoolBlacken(Pool pool, TraceSet traceSet, Seg seg);
 extern Res PoolScan(ScanState ss, Pool pool, Seg seg);
 extern Res (PoolFix)(Pool pool, ScanState ss, Seg seg, Addr *refIO);
 #define PoolFix(pool, ss, seg, refIO) \
@@ -301,6 +302,8 @@ extern Res PoolTrivTraceBegin(Pool pool, Trace trace, Action action);
 extern Res PoolNoCondemn(Pool pool, Trace trace, Seg seg, Action action);
 extern void PoolNoGrey(Pool pool, Trace trace, Seg seg);
 extern void PoolTrivGrey(Pool pool, Trace trace, Seg seg);
+extern void PoolNoBlacken(Pool pool, TraceSet traceSet, Seg seg);
+extern void PoolTrivBlacken(Pool pool, TraceSet traceSet, Seg seg);
 extern Res PoolNoScan(ScanState ss, Pool pool, Seg seg);
 extern Res PoolNoFix(Pool pool, ScanState ss, Seg seg, Ref *refIO);
 extern void PoolNoReclaim(Pool pool, Trace trace, Seg seg);
diff --git a/mps/src/mpmst.h b/mps/src/mpmst.h
index bc8377197fd..33008edea5f 100644
--- a/mps/src/mpmst.h
+++ b/mps/src/mpmst.h
@@ -1,6 +1,6 @@
 /* impl.h.mpmst: MEMORY POOL MANAGER DATA STRUCTURES
  *
- * $HopeName: MMsrc!mpmst.h(trunk.32) $
+ * $HopeName: MMsrc!mpmst.h(trunk.33) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * .readership: MM developers.
@@ -88,6 +88,7 @@ typedef struct PoolClassStruct {
   PoolTraceBeginMethod traceBegin;
   PoolCondemnMethod condemn;    /* condemn (some or all) objects */
   PoolGreyMethod grey;          /* grey non-white objects */
+  PoolBlackenMethod blacken;    /* blacken grey objects without scanning */
   PoolScanMethod scan;          /* find references during tracing */
   PoolFixMethod fix;            /* referent reachable during tracing */
   PoolReclaimMethod reclaim;    /* reclaim dead objects after tracing */
diff --git a/mps/src/mpmtypes.h b/mps/src/mpmtypes.h
index f6c64425a3e..15d77ead811 100644
--- a/mps/src/mpmtypes.h
+++ b/mps/src/mpmtypes.h
@@ -1,6 +1,6 @@
 /* impl.h.mpmtypes: MEMORY POOL MANAGER TYPES
  *
- * $HopeName: MMsrc!mpmtypes.h(trunk.29) $
+ * $HopeName: MMsrc!mpmtypes.h(trunk.30) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * .readership: MM developers.
@@ -111,6 +111,7 @@ typedef Res (*PoolTraceBeginMethod)(Pool pool, Trace trace,
 typedef Res (*PoolCondemnMethod)(Pool pool, Trace trace, 
                                  Seg seg, Action action);
 typedef void (*PoolGreyMethod)(Pool pool, Trace trace, Seg seg);
+typedef void (*PoolBlackenMethod)(Pool pool, TraceSet traceSet, Seg seg);
 typedef Res (*PoolScanMethod)(ScanState ss, Pool pool, Seg seg);
 typedef Res (*PoolFixMethod)(Pool pool, ScanState ss, Seg seg,
                              Ref *refIO);
diff --git a/mps/src/pool.c b/mps/src/pool.c
index 0171d17ed58..07bb6d7f5f6 100644
--- a/mps/src/pool.c
+++ b/mps/src/pool.c
@@ -1,6 +1,6 @@
 /* impl.c.pool: POOL IMPLEMENTATION
  *
- * $HopeName: MMsrc!pool.c(trunk.34) $
+ * $HopeName: MMsrc!pool.c(trunk.35) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * This is the implementation of the generic pool interface.  The
@@ -12,7 +12,7 @@
 
 #include "mpm.h"
 
-SRCID(pool, "$HopeName: MMsrc!pool.c(trunk.34) $");
+SRCID(pool, "$HopeName: MMsrc!pool.c(trunk.35) $");
 
 
 Bool PoolClassCheck(PoolClass class)
@@ -282,6 +282,15 @@ void PoolGrey(Pool pool, Trace trace, Seg seg)
   (*pool->class->grey)(pool, trace, seg);
 }
 
+void PoolBlacken(Pool pool, TraceSet traceSet, Seg seg)
+{
+  AVERT(Pool, pool);
+  AVERT(TraceSet, traceSet);
+  AVERT(Seg, seg);
+  AVER(SegPool(seg) == pool);
+  (*pool->class->blacken)(pool, traceSet, seg);
+}
+
 Res PoolScan(ScanState ss, Pool pool, Seg seg)
 {
   AVERT(ScanState, ss);
@@ -652,6 +661,25 @@ void PoolTrivGrey(Pool pool, Trace trace, Seg seg)
     SegSetGrey(seg, TraceSetSingle(trace->ti));
 }
 
+void PoolNoBlacken(Pool pool, TraceSet traceSet, Seg seg)
+{
+  AVERT(Pool, pool);
+  AVERT(TraceSet, traceSet);
+  AVERT(Seg, seg);
+  NOTREACHED;
+}
+
+void PoolTrivBlacken(Pool pool, TraceSet traceSet, Seg seg)
+{
+  AVERT(Pool, pool);
+  AVERT(TraceSet, traceSet);
+  AVERT(Seg, seg);
+
+  /* the trivial blacken method does nothing; for pool classes which do
+   * not keep additional colour information. */
+  NOOP;
+}
+
 Res PoolNoScan(ScanState ss, Pool pool, Seg seg)
 {
   AVERT(ScanState, ss);
diff --git a/mps/src/poolams.c b/mps/src/poolams.c
index 401b5a9fbcf..dc89279eb79 100644
--- a/mps/src/poolams.c
+++ b/mps/src/poolams.c
@@ -1,6 +1,6 @@
 /* impl.c.poolams: AUTOMATIC MARK & SWEEP POOL CLASS
  *
- * $HopeName: MMsrc!poolams.c(trunk.7) $
+ * $HopeName: MMsrc!poolams.c(trunk.8) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  * 
  * NOTES
@@ -19,7 +19,7 @@
 #include "mpm.h"
 #include "mpscams.h"
 
-SRCID(poolams, "$HopeName: MMsrc!poolams.c(trunk.7) $");
+SRCID(poolams, "$HopeName: MMsrc!poolams.c(trunk.8) $");
 
 
 #define AMSSig          ((Sig)0x519A3599) /* SIGnature AMS */
@@ -686,6 +686,66 @@ static Res AMSIterate(AMS ams, AMSGroup group, Seg seg, Arena arena,
 }
 
 
+/* AMSBlackenObject -- blacken a single object (if it is grey).
+ * 
+ * This is the object function passed to AMSIterate by AMSBlacken.
+ * It just blackens the object if it is grey. It takes no closure.
+ */
+
+static Res AMSBlackenObject(AMSGroup group,
+			    Index i, Addr p, Addr next, int colour,
+			    void *clos)
+{
+  AVERT(AMSGroup, group);
+  AVER(i < group->grains);
+  AVER(p != 0);
+  AVER(p < next);
+  AVER(clos == NULL);
+  AVER(colour != AMS_ILLEGAL);
+  AVER(AMSColourIsValid(colour));
+
+  /* if the object is grey, make it black */
+  if (colour == AMS_GREY) 
+    BTSet(group->scanTable, i);
+
+  return ResOK;
+}
+
+/* AMSBlacken -- the pool class segment blackening method
+ *
+ * See design.mps.poolams.blacken
+ */
+
+static void AMSBlacken(Pool pool, TraceSet traceSet, Seg seg)
+{
+  Res res;
+  AMS ams;
+  Arena arena;
+  AMSGroup group;
+
+  AVERT(Pool, pool);
+  AVER(TraceSetCheck(traceSet));
+  AVER(SegCheck(seg));
+
+  /* only do anything if the bitmaps apply to one of these traces. */
+  /* see design.mps.poolams.invariant.object */
+  if (TraceSetInter(SegWhite(seg), traceSet) != TraceSetEMPTY) {
+    ams = PoolPoolAMS(pool);
+    AVERT(AMS, ams);
+    arena = PoolArena(pool);
+
+    group = AMSSegGroup(seg);
+    AVERT(AMSGroup, group);
+
+    ShieldExpose(arena, seg); /* so we can skip through it */
+    res = AMSIterate(ams, group, seg, arena, AMSBlackenObject, NULL);
+    AVER(res == ResOK); /* AMSBlackenObject always returns ResOK */
+    ShieldCover(arena, seg);
+
+    group->marked = FALSE; /* design.mps.poolams.blacken.marked */
+  }
+}
+
 /* The closure of the object scanning function */
 
 struct AMSScanClosureStruct {
@@ -773,6 +833,7 @@ static Res AMSScan(ScanState ss, Pool pool, Seg seg)
 		     &closureStruct);
     if (res != ResOK)
       return res;
+    group->marked = FALSE;
     
   } else { /* design.mps.poolams.scan.iter */
 
@@ -1150,6 +1211,7 @@ static PoolClassStruct PoolClassAMSStruct = {
   PoolTrivTraceBegin,        /* design.mps.poolams.triv-trace-begin */
   AMSCondemn,                /* condemn */
   PoolTrivGrey,              /* design.mps.poolams.triv-grey */
+  AMSBlacken,                /* blacken */
   AMSScan,                   /* scan */
   AMSFix,                    /* fix */
   AMSReclaim,                /* reclaim */
diff --git a/mps/src/poolawl.c b/mps/src/poolawl.c
index c47dee78cdc..ec78c980e9d 100644
--- a/mps/src/poolawl.c
+++ b/mps/src/poolawl.c
@@ -1,6 +1,6 @@
 /* impl.c.poolawl: AUTOMATIC WEAK LINKED POOL CLASS
  *
- * $HopeName: MMsrc!poolawl.c(trunk.15) $
+ * $HopeName: MMsrc!poolawl.c(trunk.16) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * READERSHIP
@@ -16,7 +16,7 @@
 #include "mpm.h"
 #include "mpscawl.h"
 
-SRCID(poolawl, "$HopeName: MMsrc!poolawl.c(trunk.15) $");
+SRCID(poolawl, "$HopeName: MMsrc!poolawl.c(trunk.16) $");
 
 
 #define AWLSig	((Sig)0x519b7a37)	/* SIGPooLAWL */
@@ -384,6 +384,23 @@ static void AWLGrey(Pool pool, Trace trace, Seg seg)
   }
 }
 
+static void AWLBlacken(Pool pool, TraceSet traceSet, Seg seg)
+{
+  AWL awl;
+  AWLGroup group;
+
+  AVERT(Pool, pool);
+  AVER(TraceSetCheck(traceSet));
+  AVER(SegCheck(seg));
+
+  awl = PoolPoolAWL(pool);
+  AVERT(AWL, awl);
+  group = (AWLGroup)SegP(seg);
+  AVERT(AWLGroup, group);
+  
+  BTSetRange(group->scanned, 0, group->grains);
+}
+
 
 /* Returns the linked object (or possibly there is none) */
 /* see design.mps.poolawl.fun.dependent-object, and */
@@ -676,6 +693,7 @@ struct PoolClassStruct PoolClassAWLStruct = {
   AWLTraceBegin,
   AWLCondemn,
   AWLGrey,
+  AWLBlacken,
   AWLScan,
   AWLFix,
   AWLReclaim,
diff --git a/mps/src/poolmfs.c b/mps/src/poolmfs.c
index 013cec68508..e1ed7152570 100644
--- a/mps/src/poolmfs.c
+++ b/mps/src/poolmfs.c
@@ -1,6 +1,6 @@
 /* impl.c.poolmfs: MANUAL FIXED SMALL UNIT POOL
  *
- * $HopeName: MMsrc!poolmfs.c(trunk.21) $
+ * $HopeName: MMsrc!poolmfs.c(trunk.22) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * This is the implementation of the MFS pool class.
@@ -35,7 +35,7 @@
 #include "mpm.h"
 #include "poolmfs.h"
 
-SRCID(poolmfs, "$HopeName: MMsrc!poolmfs.c(trunk.21) $");
+SRCID(poolmfs, "$HopeName: MMsrc!poolmfs.c(trunk.22) $");
 
 
 /*  == Round up ==
@@ -278,6 +278,7 @@ static PoolClassStruct PoolClassMFSStruct = {
   PoolNoTraceBegin,			/* traceBegin */
   PoolNoCondemn,                        /* condemn */
   PoolNoGrey,                           /* grey */
+  PoolNoBlacken,                        /* blacken */
   PoolNoScan,                           /* scan */
   PoolNoFix,                            /* fix */
   PoolNoReclaim,                        /* reclaim */
diff --git a/mps/src/poolmrg.c b/mps/src/poolmrg.c
index 14ef8d02327..6296662fd2f 100644
--- a/mps/src/poolmrg.c
+++ b/mps/src/poolmrg.c
@@ -2,7 +2,7 @@
  * 
  * MANUAL RANK GUARDIAN POOL
  * 
- * $HopeName: MMsrc!poolmrg.c(trunk.12) $
+ * $HopeName: MMsrc!poolmrg.c(trunk.13) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * READERSHIP
@@ -28,7 +28,7 @@
 #include "mpm.h"
 #include "poolmrg.h"
 
-SRCID(poolmrg, "$HopeName: MMsrc!poolmrg.c(trunk.12) $");
+SRCID(poolmrg, "$HopeName: MMsrc!poolmrg.c(trunk.13) $");
 
 
 #define MRGSig          ((Sig)0x519369B0) /* SIGnature MRG POol */
@@ -418,6 +418,7 @@ static PoolClassStruct PoolClassMRGStruct = {
   PoolNoTraceBegin,			/* traceBegin */
   PoolNoCondemn,                        /* condemn */
   PoolTrivGrey,                         /* grey */
+  PoolTrivBlacken,                      /* blacken */
   MRGScan,                              /* scan */
   PoolNoFix,                            /* fix */
   PoolNoReclaim,                        /* reclaim */
diff --git a/mps/src/poolmv.c b/mps/src/poolmv.c
index 6e3e0acf0ca..672997a4701 100644
--- a/mps/src/poolmv.c
+++ b/mps/src/poolmv.c
@@ -1,6 +1,6 @@
 /* impl.c.poolmv: MANUAL VARIABLE POOL
  *
- * $HopeName: MMsrc!poolmv.c(trunk.22) $
+ * $HopeName: MMsrc!poolmv.c(trunk.23) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * **** RESTRICTION: This pool may not allocate from the arena control
@@ -37,7 +37,7 @@
 #include "poolmfs.h"
 #include "mpscmv.h"
 
-SRCID(poolmv, "$HopeName: MMsrc!poolmv.c(trunk.22) $");
+SRCID(poolmv, "$HopeName: MMsrc!poolmv.c(trunk.23) $");
 
 
 #define BLOCKPOOL(mv)   (MFSPool(&(mv)->blockPoolStruct))
@@ -621,7 +621,8 @@ static PoolClassStruct PoolClassMVStruct = {
   PoolTrivBufferFinish,                 /* bufferFinish */
   PoolNoTraceBegin,			/* traceBegin */
   PoolNoCondemn,                        /* condemn */
-  PoolNoGrey,                           /* mark */
+  PoolNoGrey,                           /* grey */
+  PoolNoBlacken,                        /* blacken */
   PoolNoScan,                           /* scan */
   PoolNoFix,                            /* fix */
   PoolNoReclaim,                        /* relcaim */
diff --git a/mps/src/pooln.c b/mps/src/pooln.c
index 46641f234a9..cc5e5f0dafe 100644
--- a/mps/src/pooln.c
+++ b/mps/src/pooln.c
@@ -1,6 +1,6 @@
 /* impl.c.pooln: NULL POOL
  *
- * $HopeName: MMsrc!pooln.c(trunk.12) $
+ * $HopeName: MMsrc!pooln.c(trunk.13) $
  * Copyright(C) 1997 The Harlequin Group Limited.  All rights reserved.
  *
  * This is the implementation of the null pool class.  Begin null it
@@ -10,7 +10,7 @@
 #include "mpm.h"
 #include "pooln.h"
 
-SRCID(pooln, "$HopeName: MMsrc!pooln.c(trunk.12) $");
+SRCID(pooln, "$HopeName: MMsrc!pooln.c(trunk.13) $");
 
 
 typedef struct PoolNStruct {
@@ -177,6 +177,18 @@ static void NGrey(Pool pool, Trace trace, Seg seg)
   AVERT(Seg, seg);
 }
 
+static void NBlacken(Pool pool, TraceSet traceSet, Seg seg)
+{
+  PoolN poolN;
+
+  AVERT(Pool, pool);
+  poolN = PoolPoolN(pool);
+  AVERT(PoolN, poolN);
+
+  AVERT(TraceSet, traceSet);
+  AVERT(Seg, seg);
+}
+
 static Res NScan(ScanState ss, Pool pool, Seg seg)
 {
   PoolN poolN;
@@ -237,6 +249,7 @@ static PoolClassStruct PoolClassNStruct = {
   PoolNoTraceBegin,			/* traceBegin */
   NCondemn,                             /* condemn */
   NGrey,                                /* grey */
+  NBlacken,                             /* blacken */
   NScan,                                /* scan */
   NFix,                                 /* fix */
   NReclaim,                             /* reclaim */
diff --git a/mps/src/trace.c b/mps/src/trace.c
index 932c77bca32..28f9b691ea0 100644
--- a/mps/src/trace.c
+++ b/mps/src/trace.c
@@ -1,12 +1,12 @@
 /* impl.c.trace: GENERIC TRACER IMPLEMENTATION
  *
- * $HopeName: MMsrc!trace.c(trunk.43) $
+ * $HopeName: MMsrc!trace.c(trunk.44) $
  * Copyright (C) 1997 The Harlequin Group Limited.  All rights reserved.
  */
 
 #include "mpm.h"
 
-SRCID(trace, "$HopeName: MMsrc!trace.c(trunk.43) $");
+SRCID(trace, "$HopeName: MMsrc!trace.c(trunk.44) $");
 
 
 /* ScanStateCheck -- check consistency of a ScanState object */
@@ -608,7 +608,9 @@ static Res TraceScan(TraceSet ts, Rank rank,
       white = RefSetUnion(white, ArenaTrace(arena, ti)->white);
 
   /* only scan a segment if it refers to the white set */
-  if (RefSetInter(white, SegSummary(seg)) != RefSetEMPTY) {
+  if (RefSetInter(white, SegSummary(seg)) == RefSetEMPTY) { /* blacken it */
+    PoolBlacken(SegPool(seg), ts, seg);
+  } else {  /* scan it */
     ss.rank = rank;
     ss.traces = ts;
     ss.fix = TraceFix;
@@ -644,7 +646,7 @@ static Res TraceScan(TraceSet ts, Rank rank,
     ss.sig = SigInvalid;                  /* just in case */
   }
 
-  /* The segment has been scanned, so remove the greyness from it. */
+  /* The segment is now black, so remove the greyness from it. */
   SegSetGrey(seg, TraceSetDiff(SegGrey(seg), ts));
 
   return ResOK;