From f20f244e7c89426d69fc99fa7703d89c40120f02 Mon Sep 17 00:00:00 2001
From: Gareth Rees <gdr@ravenbrook.com>
Date: Mon, 18 Jun 2018 21:16:02 +0100
Subject: [PATCH 1/6] Branching master to branch/2018-06-18/mrgseg.

Copied from Perforce
 Change: 193951

From f61af11694a9122b1fcbff70bd8725838e74fee0 Mon Sep 17 00:00:00 2001
From: Gareth Rees <gdr@ravenbrook.com>
Date: Tue, 19 Jun 2018 12:27:07 +0100
Subject: [PATCH 2/6] Postpone some lookups until it is known that they are
 needed (avoiding the lookups in the common case where they are not).

Copied from Perforce
 Change: 193975
---
 mps/code/seg.c | 26 ++++++++------------------
 1 file changed, 8 insertions(+), 18 deletions(-)

diff --git a/mps/code/seg.c b/mps/code/seg.c
index a1080f67881..8c258fc4d0d 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -1268,38 +1268,33 @@ static void gcSegSetWhite(Seg seg, TraceSet white)
 
 static void gcSegSetRankSet(Seg seg, RankSet rankSet)
 {
-  GCSeg gcseg;
   RankSet oldRankSet;
-  Arena arena;
 
   AVERT_CRITICAL(Seg, seg);                /* .seg.method.check */
   AVERT_CRITICAL(RankSet, rankSet);        /* .seg.method.check */
   AVER_CRITICAL(rankSet == RankSetEMPTY
                 || RankSetIsSingle(rankSet)); /* .seg.method.check */
-  gcseg = SegGCSeg(seg);
-  AVERT_CRITICAL(GCSeg, gcseg);
-  AVER_CRITICAL(&gcseg->segStruct == seg);
 
-  arena = PoolArena(SegPool(seg));
   oldRankSet = seg->rankSet;
   seg->rankSet = BS_BITFIELD(Rank, rankSet);
 
   if (oldRankSet == RankSetEMPTY) {
     if (rankSet != RankSetEMPTY) {
-      AVER(gcseg->summary == RefSetEMPTY);
-      ShieldRaise(arena, seg, AccessWRITE);
+      AVER_CRITICAL(SegGCSeg(seg)->summary == RefSetEMPTY);
+      ShieldRaise(PoolArena(SegPool(seg)), seg, AccessWRITE);
     }
   } else {
     if (rankSet == RankSetEMPTY) {
-      AVER(gcseg->summary == RefSetEMPTY);
-      ShieldLower(arena, seg, AccessWRITE);
+      AVER_CRITICAL(SegGCSeg(seg)->summary == RefSetEMPTY);
+      ShieldLower(PoolArena(SegPool(seg)), seg, AccessWRITE);
     }
   }
 }
 
 
-static void gcSegSyncWriteBarrier(Seg seg, Arena arena)
+static void gcSegSyncWriteBarrier(Seg seg)
 {
+  Arena arena = PoolArena(SegPool(seg));
   /* Can't check seg -- this function enforces invariants tested by SegCheck. */
   if (SegSummary(seg) == RefSetUNIV)
     ShieldLower(arena, seg, AccessWRITE);
@@ -1320,19 +1315,17 @@ static void gcSegSyncWriteBarrier(Seg seg, Arena arena)
 static void gcSegSetSummary(Seg seg, RefSet summary)
 {
   GCSeg gcseg;
-  Arena arena;
 
   AVERT_CRITICAL(Seg, seg);                 /* .seg.method.check */
   gcseg = SegGCSeg(seg);
   AVERT_CRITICAL(GCSeg, gcseg);
   AVER_CRITICAL(&gcseg->segStruct == seg);
 
-  arena = PoolArena(SegPool(seg));
   gcseg->summary = summary;
 
   AVER(seg->rankSet != RankSetEMPTY);
 
-  gcSegSyncWriteBarrier(seg, arena);
+  gcSegSyncWriteBarrier(seg);
 }
 
 
@@ -1341,7 +1334,6 @@ static void gcSegSetSummary(Seg seg, RefSet summary)
 static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
 {
   GCSeg gcseg;
-  Arena arena;
 
   AVERT_CRITICAL(Seg, seg);                    /* .seg.method.check */
   AVERT_CRITICAL(RankSet, rankSet);            /* .seg.method.check */
@@ -1354,13 +1346,11 @@ static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
   /* rankSet == RankSetEMPTY implies summary == RefSetEMPTY */
   AVER(rankSet != RankSetEMPTY || summary == RefSetEMPTY);
 
-  arena = PoolArena(SegPool(seg));
-
   seg->rankSet = BS_BITFIELD(Rank, rankSet);
   gcseg->summary = summary;
 
   if (rankSet != RankSetEMPTY)
-    gcSegSyncWriteBarrier(seg, arena);
+    gcSegSyncWriteBarrier(seg);
 }
 
 

From 7f7822d4abf5454d9121244da0ee77b26b8a0a97 Mon Sep 17 00:00:00 2001
From: Gareth Rees <gdr@ravenbrook.com>
Date: Tue, 19 Jun 2018 14:45:42 +0100
Subject: [PATCH 3/6] Segment class gcseg no longer implements hardware
 barriers; these are implemented by new subclass mutatorseg, which is now used
 everywhere that gcseg was used formerly. the idea is that in a future change
 mrgrefseg will inherit from gcseg instead of mutatorseg.

Copied from Perforce
 Change: 193981
---
 mps/code/locus.c       |  11 +--
 mps/code/mpm.h         |   1 +
 mps/code/poolamc.c     |   4 +-
 mps/code/poolams.c     |   2 +-
 mps/code/poolams.h     |   2 +-
 mps/code/poolawl.c     |   9 +--
 mps/code/poollo.c      |   4 +-
 mps/code/poolmrg.c     |   4 +-
 mps/code/poolsnc.c     |   6 +-
 mps/code/seg.c         | 148 +++++++++++++++++++++++++++--------------
 mps/design/poolamc.txt |   5 +-
 mps/design/poolawl.txt |   8 +--
 mps/design/poollo.txt  |   8 ++-
 mps/design/poolmrg.txt |   2 +-
 mps/design/seg.txt     |  12 +++-
 15 files changed, 142 insertions(+), 84 deletions(-)

diff --git a/mps/code/locus.c b/mps/code/locus.c
index a93fb72f0ae..7f78e17831b 100644
--- a/mps/code/locus.c
+++ b/mps/code/locus.c
@@ -605,11 +605,11 @@ static void PoolGenAccountForAlloc(PoolGen pgen, Size size)
 
 /* PoolGenAlloc -- allocate a segment in a pool generation
  *
- * Allocate a GCSeg, attach it to the generation, and update the
- * accounting.
+ * Allocate a segment belong to klass (which must be GCSegClass or a
+ * subclass), attach it to the generation, and update the accounting.
  */
 
-Res PoolGenAlloc(Seg *segReturn, PoolGen pgen, SegClass class, Size size,
+Res PoolGenAlloc(Seg *segReturn, PoolGen pgen, SegClass klass, Size size,
                  ArgList args)
 {
   LocusPrefStruct pref;
@@ -621,7 +621,8 @@ Res PoolGenAlloc(Seg *segReturn, PoolGen pgen, SegClass class, Size size,
 
   AVER(segReturn != NULL);
   AVERT(PoolGen, pgen);
-  AVERT(SegClass, class);
+  AVERT(SegClass, klass);
+  AVER(IsSubclass(klass, GCSeg));
   AVER(size > 0);
   AVERT(ArgList, args);
 
@@ -633,7 +634,7 @@ Res PoolGenAlloc(Seg *segReturn, PoolGen pgen, SegClass class, Size size,
   pref.high = FALSE;
   pref.zones = zones;
   pref.avoid = ZoneSetBlacklist(arena);
-  res = SegAlloc(&seg, class, &pref, size, pgen->pool, args);
+  res = SegAlloc(&seg, klass, &pref, size, pgen->pool, args);
   if (res != ResOK)
     return res;
 
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index 410dd0b3c6c..4bb6638abbf 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -681,6 +681,7 @@ extern Bool SegClassCheck(SegClass klass);
 DECLARE_CLASS(Inst, SegClass, InstClass);
 DECLARE_CLASS(Seg, Seg, Inst);
 DECLARE_CLASS(Seg, GCSeg, Seg);
+DECLARE_CLASS(Seg, MutatorSeg, GCSeg);
 #define SegGCSeg(seg) MustBeA(GCSeg, (seg))
 extern void SegClassMixInNoSplitMerge(SegClass klass);
 
diff --git a/mps/code/poolamc.c b/mps/code/poolamc.c
index 07750ecddcb..fe345b5b49b 100644
--- a/mps/code/poolamc.c
+++ b/mps/code/poolamc.c
@@ -38,7 +38,7 @@ typedef AMC AMCPool;
 DECLARE_CLASS(Pool, AMCPool, AMCZPool);
 
 DECLARE_CLASS(Buffer, amcBuf, SegBuf);
-DECLARE_CLASS(Seg, amcSeg, GCSeg);
+DECLARE_CLASS(Seg, amcSeg, MutatorSeg);
 
 
 /* amcGenStruct -- pool AMC generation descriptor */
@@ -331,7 +331,7 @@ static Res AMCSegDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
 
 DEFINE_CLASS(Seg, amcSeg, klass)
 {
-  INHERIT_CLASS(klass, amcSeg, GCSeg);
+  INHERIT_CLASS(klass, amcSeg, MutatorSeg);
   SegClassMixInNoSplitMerge(klass);  /* no support for this (yet) */
   klass->instClassStruct.describe = AMCSegDescribe;
   klass->size = sizeof(amcSegStruct);
diff --git a/mps/code/poolams.c b/mps/code/poolams.c
index 068e7f688e6..c17c43d7eb0 100644
--- a/mps/code/poolams.c
+++ b/mps/code/poolams.c
@@ -598,7 +598,7 @@ static Res AMSSegDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
 
 DEFINE_CLASS(Seg, AMSSeg, klass)
 {
-  INHERIT_CLASS(klass, AMSSeg, GCSeg);
+  INHERIT_CLASS(klass, AMSSeg, MutatorSeg);
   klass->instClassStruct.describe = AMSSegDescribe;
   klass->instClassStruct.finish = AMSSegFinish;
   klass->size = sizeof(AMSSegStruct);
diff --git a/mps/code/poolams.h b/mps/code/poolams.h
index 1bd60e7900d..990e0f16225 100644
--- a/mps/code/poolams.h
+++ b/mps/code/poolams.h
@@ -191,7 +191,7 @@ DECLARE_CLASS(Pool, AMSPool, AbstractCollectPool);
 typedef AMS AMSDebugPool;
 DECLARE_CLASS(Pool, AMSDebugPool, AMSPool);
 
-DECLARE_CLASS(Seg, AMSSeg, GCSeg);
+DECLARE_CLASS(Seg, AMSSeg, MutatorSeg);
 
 
 #endif /* poolams_h */
diff --git a/mps/code/poolawl.c b/mps/code/poolawl.c
index 8d58bd81d89..c4c1b6c6ab9 100644
--- a/mps/code/poolawl.c
+++ b/mps/code/poolawl.c
@@ -110,10 +110,7 @@ DECLARE_CLASS(Pool, AWLPool, AbstractCollectPool);
   AddrAdd(base, AWLGrainsSize(awl, i))
 
 
-/* AWLSegStruct -- AWL segment subclass
- *
- * Subclass of GCSeg
- */
+/* AWLSegStruct -- AWL segment subclass */
 
 #define AWLSegSig ((Sig)0x519A3759) /* SIGnature AWL SeG */
 
@@ -133,7 +130,7 @@ typedef struct AWLSegStruct {
   Sig sig;
 } AWLSegStruct, *AWLSeg;
 
-DECLARE_CLASS(Seg, AWLSeg, GCSeg);
+DECLARE_CLASS(Seg, AWLSeg, MutatorSeg);
 
 ATTRIBUTE_UNUSED
 static Bool AWLSegCheck(AWLSeg awlseg)
@@ -278,7 +275,7 @@ static void AWLSegFinish(Inst inst)
 
 DEFINE_CLASS(Seg, AWLSeg, klass)
 {
-  INHERIT_CLASS(klass, AWLSeg, GCSeg);
+  INHERIT_CLASS(klass, AWLSeg, MutatorSeg);
   SegClassMixInNoSplitMerge(klass);  /* no support for this (yet) */
   klass->instClassStruct.finish = AWLSegFinish;
   klass->size = sizeof(AWLSegStruct);
diff --git a/mps/code/poollo.c b/mps/code/poollo.c
index 97f50f04fed..93f29e06aa1 100644
--- a/mps/code/poollo.c
+++ b/mps/code/poollo.c
@@ -34,7 +34,7 @@ typedef struct LOStruct {
 typedef LO LOPool;
 #define LOPoolCheck LOCheck
 DECLARE_CLASS(Pool, LOPool, AbstractSegBufPool);
-DECLARE_CLASS(Seg, LOSeg, GCSeg);
+DECLARE_CLASS(Seg, LOSeg, MutatorSeg);
 
 
 /* forward declaration */
@@ -69,7 +69,7 @@ static Count loSegGrains(LOSeg loseg);
 
 DEFINE_CLASS(Seg, LOSeg, klass)
 {
-  INHERIT_CLASS(klass, LOSeg, GCSeg);
+  INHERIT_CLASS(klass, LOSeg, MutatorSeg);
   SegClassMixInNoSplitMerge(klass);
   klass->instClassStruct.finish = loSegFinish;
   klass->size = sizeof(LOSegStruct);
diff --git a/mps/code/poolmrg.c b/mps/code/poolmrg.c
index 28fdf3a503f..12bbf6b2953 100644
--- a/mps/code/poolmrg.c
+++ b/mps/code/poolmrg.c
@@ -166,7 +166,7 @@ typedef struct MRGRefSegStruct {
 /* forward declarations */
 
 DECLARE_CLASS(Seg, MRGLinkSeg, Seg);
-DECLARE_CLASS(Seg, MRGRefSeg, GCSeg);
+DECLARE_CLASS(Seg, MRGRefSeg, MutatorSeg);
 
 
 /* MRGLinkSegCheck -- check a link segment
@@ -296,7 +296,7 @@ DEFINE_CLASS(Seg, MRGLinkSeg, klass)
 
 DEFINE_CLASS(Seg, MRGRefSeg, klass)
 {
-  INHERIT_CLASS(klass, MRGRefSeg, GCSeg);
+  INHERIT_CLASS(klass, MRGRefSeg, MutatorSeg);
   SegClassMixInNoSplitMerge(klass);  /* no support for this */
   klass->size = sizeof(MRGRefSegStruct);
   klass->init = MRGRefSegInit;
diff --git a/mps/code/poolsnc.c b/mps/code/poolsnc.c
index cef85f2113a..f1abb5e132f 100644
--- a/mps/code/poolsnc.c
+++ b/mps/code/poolsnc.c
@@ -47,7 +47,7 @@ typedef SNC SNCPool;
 #define SNCPoolCheck SNCCheck
 DECLARE_CLASS(Pool, SNCPool, AbstractScanPool);
 
-DECLARE_CLASS(Seg, SNCSeg, GCSeg);
+DECLARE_CLASS(Seg, SNCSeg, MutatorSeg);
 DECLARE_CLASS(Buffer, SNCBuf, RankBuf);
 static Bool SNCCheck(SNC snc);
 static void sncPopPartialSegChain(SNC snc, Buffer buf, Seg upTo);
@@ -167,7 +167,7 @@ DEFINE_CLASS(Buffer, SNCBuf, klass)
 
 /* SNCSegStruct -- SNC segment subclass
  *
- * This subclass of GCSeg links segments in chains.
+ * This subclass of MutatorSeg links segments in chains.
  */
 
 #define SNCSegSig ((Sig)0x51954C59)    /* SIGSNCSeG */
@@ -229,7 +229,7 @@ static Res sncSegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
 
 DEFINE_CLASS(Seg, SNCSeg, klass)
 {
-  INHERIT_CLASS(klass, SNCSeg, GCSeg);
+  INHERIT_CLASS(klass, SNCSeg, MutatorSeg);
   SegClassMixInNoSplitMerge(klass);  /* no support for this (yet) */
   klass->size = sizeof(SNCSegStruct);
   klass->init = sncSegInit;
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 8c258fc4d0d..5177913ea3c 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -7,15 +7,8 @@
  *
  * PURPOSE
  *
- * .purpose: This is the implementation of the generic segment interface.
- * It defines the interface functions and two useful segment classes:
- * .purpose.class.seg: Class Seg is a class which is as simple
- * as efficiency demands permit.  (It includes fields for storing colour
- * for efficiency).  It may be subclassed by clients of the module.
- * .purpose.class.seg-gc: Class GCSeg is a concrete class support all
- * all current GC features, and providing full backwards compatibility
- * with "old-style" segments.  It may be subclassed by clients of the
- * module.
+ * .purpose: This is the implementation of the generic segment
+ * interface and the segment classes Seg, GCSeg and MutatorSeg.
  */
 
 #include "tract.h"
@@ -113,7 +106,7 @@ void SegFree(Seg seg)
 
 /* SegInit -- initialize a segment */
 
-static Res SegAbsInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
+static Res segAbsInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
 {
   Arena arena;
   Addr addr, limit;
@@ -185,7 +178,7 @@ static Res SegInit(Seg seg, SegClass klass, Pool pool, Addr base, Size size, Arg
 
 /* SegFinish -- finish a segment */
 
-static void SegAbsFinish(Inst inst)
+static void segAbsFinish(Inst inst)
 {
   Seg seg = MustBeA(Seg, inst);
   Arena arena;
@@ -259,6 +252,8 @@ void SegSetGrey(Seg seg, TraceSet grey)
      greyness, or if the segment doesn't contain any references. */
   if (grey != SegGrey(seg) && SegRankSet(seg) != RankSetEMPTY)
     Method(Seg, seg, setGrey)(seg, grey);
+
+  EVENT3(SegSetGrey, PoolArena(SegPool(seg)), seg, grey);
 }
 
 
@@ -385,7 +380,7 @@ Addr SegBufferScanLimit(Seg seg)
 
 /* SegDescribe -- describe a segment */
 
-Res SegAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
+static Res segAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
 {
   Seg seg = CouldBeA(Seg, inst);
   Res res;
@@ -1028,8 +1023,7 @@ static Res segTrivSplit(Seg seg, Seg segHi,
 }
 
 
-/* Class GCSeg -- Segment class with GC support
- */
+/* Class GCSeg -- collectable segment class */
 
 
 /* GCSegCheck -- check the integrity of a GCSeg */
@@ -1179,31 +1173,39 @@ static void gcSegSetGreyInternal(Seg seg, TraceSet oldGrey, TraceSet grey)
 
 /* gcSegSetGrey -- GCSeg method to change the greyness of a segment
  *
- * Sets the segment greyness to the trace set grey and adjusts
- * the shielding on the segment appropriately.
+ * Sets the segment greyness to the trace set grey.
  */
 
 static void gcSegSetGrey(Seg seg, TraceSet grey)
 {
-  GCSeg gcseg;
+  AVERT_CRITICAL(Seg, seg);            /* .seg.method.check */
+  AVERT_CRITICAL(TraceSet, grey);      /* .seg.method.check */
+  AVER_CRITICAL(seg->rankSet != RankSetEMPTY);
+
+  gcSegSetGreyInternal(seg, seg->grey, grey); /* do the work */
+}
+
+
+/* mutatorSegSetGrey -- MutatorSeg method to change greyness of segment
+ *
+ * As gcSegSetGrey, but also raise or lower the read barrier.
+ */
+
+static void mutatorSegSetGrey(Seg seg, TraceSet grey)
+{
   TraceSet oldGrey, flippedTraces;
   Arena arena;
  
   AVERT_CRITICAL(Seg, seg);            /* .seg.method.check */
-  AVERT_CRITICAL(TraceSet, grey);      /* .seg.method.check */
-  AVER(seg->rankSet != RankSetEMPTY);
-  gcseg = SegGCSeg(seg);
-  AVERT_CRITICAL(GCSeg, gcseg);
-  AVER_CRITICAL(&gcseg->segStruct == seg);
-  UNUSED(gcseg);
 
-  arena = PoolArena(SegPool(seg));
   oldGrey = seg->grey;
-  gcSegSetGreyInternal(seg, oldGrey, grey); /* do the work */
+
+  NextMethod(Seg, MutatorSeg, setGrey)(seg, grey);
 
   /* The read barrier is raised when the segment is grey for */
   /* some _flipped_ trace, i.e., is grey for a trace for which */
   /* the mutator is black. */
+  arena = PoolArena(SegPool(seg));
   flippedTraces = arena->flippedTraces;
   if (TraceSetInter(oldGrey, flippedTraces) == TraceSetEMPTY) {
     if (TraceSetInter(grey, flippedTraces) != TraceSetEMPTY)
@@ -1212,8 +1214,6 @@ static void gcSegSetGrey(Seg seg, TraceSet grey)
     if (TraceSetInter(grey, flippedTraces) == TraceSetEMPTY)
       ShieldLower(arena, seg, AccessREAD);
   }
-
-  EVENT3(SegSetGrey, arena, seg, grey);
 }
 
 
@@ -1254,12 +1254,6 @@ static void gcSegSetWhite(Seg seg, TraceSet white)
 
 
 /* gcSegSetRankSet -- GCSeg method to set the rank set of a segment
- *
- * If the rank set is made non-empty then the segment's summary is
- * now a subset of the mutator's (which is assumed to be RefSetUNIV)
- * so the write barrier must be imposed on the segment.  If the
- * rank set is made empty then there are no longer any references
- * on the segment so the barrier is removed.
  *
  * The caller must set the summary to empty before setting the rank
  * set to empty.  The caller must set the rank set to non-empty before
@@ -1268,15 +1262,35 @@ static void gcSegSetWhite(Seg seg, TraceSet white)
 
 static void gcSegSetRankSet(Seg seg, RankSet rankSet)
 {
-  RankSet oldRankSet;
-
   AVERT_CRITICAL(Seg, seg);                /* .seg.method.check */
   AVERT_CRITICAL(RankSet, rankSet);        /* .seg.method.check */
   AVER_CRITICAL(rankSet == RankSetEMPTY
                 || RankSetIsSingle(rankSet)); /* .seg.method.check */
 
-  oldRankSet = seg->rankSet;
   seg->rankSet = BS_BITFIELD(Rank, rankSet);
+}
+
+
+/* mutatorSegSetRankSet -- MutatorSeg method to set rank set of segment
+ *
+ * As gcSegSetRankSet, but also sets or clears the write barrier on
+ * the segment.
+ *
+ * If the rank set is made non-empty then the segment's summary is now
+ * a subset of the mutator's (which is assumed to be RefSetUNIV) so
+ * the write barrier must be imposed on the segment. If the rank set
+ * is made empty then there are no longer any references on the
+ * segment so the barrier is removed.
+ */
+
+static void mutatorSegSetRankSet(Seg seg, RankSet rankSet)
+{
+  RankSet oldRankSet;
+
+  AVERT_CRITICAL(Seg, seg);                /* .seg.method.check */
+  oldRankSet = seg->rankSet;
+
+  NextMethod(Seg, MutatorSeg, setRankSet)(seg, rankSet);
 
   if (oldRankSet == RankSetEMPTY) {
     if (rankSet != RankSetEMPTY) {
@@ -1292,7 +1306,16 @@ static void gcSegSetRankSet(Seg seg, RankSet rankSet)
 }
 
 
-static void gcSegSyncWriteBarrier(Seg seg)
+/* mutatorSegSyncWriteBarrier -- raise or lower write barrier on segment
+ *
+ * We only need to raise the write barrier if the segment contains
+ * references, and its summary is strictly smaller than the summary of
+ * the unprotectable data (that is, the mutator). We don't maintain
+ * such a summary, assuming that the mutator can access all
+ * references, so its summary is RefSetUNIV.
+ */
+
+static void mutatorSegSyncWriteBarrier(Seg seg)
 {
   Arena arena = PoolArena(SegPool(seg));
   /* Can't check seg -- this function enforces invariants tested by SegCheck. */
@@ -1303,14 +1326,7 @@ static void gcSegSyncWriteBarrier(Seg seg)
 }
 
 
-/* gcSegSetSummary -- GCSeg method to change the summary on a segment
- *
- * In fact, we only need to raise the write barrier if the
- * segment contains references, and its summary is strictly smaller
- * than the summary of the unprotectable data (i.e. the mutator).
- * We don't maintain such a summary, assuming that the mutator can
- * access all references, so its summary is RefSetUNIV.
- */
+/* gcSegSetSummary -- GCSeg method to change the summary on a segment */
 
 static void gcSegSetSummary(Seg seg, RefSet summary)
 {
@@ -1324,11 +1340,22 @@ static void gcSegSetSummary(Seg seg, RefSet summary)
   gcseg->summary = summary;
 
   AVER(seg->rankSet != RankSetEMPTY);
-
-  gcSegSyncWriteBarrier(seg);
 }
 
 
+/* mutatorSegSetSummary -- MutatorSeg method to change summary on segment
+ *
+ * As gcSegSetSummary, but also raise or lower the write barrier.
+ */
+
+static void mutatorSegSetSummary(Seg seg, RefSet summary)
+{
+  NextMethod(Seg, MutatorSeg, setSummary)(seg, summary);
+  mutatorSegSyncWriteBarrier(seg);
+}
+
+
+
 /* gcSegSetRankSummary -- GCSeg method to set both rank set and summary */
 
 static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
@@ -1348,9 +1375,13 @@ static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
 
   seg->rankSet = BS_BITFIELD(Rank, rankSet);
   gcseg->summary = summary;
+}
 
+static void mutatorSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
+{
+  NextMethod(Seg, MutatorSeg, setRankSummary)(seg, rankSet, summary);
   if (rankSet != RankSetEMPTY)
-    gcSegSyncWriteBarrier(seg);
+    mutatorSegSyncWriteBarrier(seg);
 }
 
 
@@ -1604,10 +1635,10 @@ DEFINE_CLASS(Inst, SegClass, klass)
 DEFINE_CLASS(Seg, Seg, klass)
 {
   INHERIT_CLASS(&klass->instClassStruct, Seg, Inst);
-  klass->instClassStruct.describe = SegAbsDescribe;
-  klass->instClassStruct.finish = SegAbsFinish;
+  klass->instClassStruct.describe = segAbsDescribe;
+  klass->instClassStruct.finish = segAbsFinish;
   klass->size = sizeof(SegStruct);
-  klass->init = SegAbsInit;
+  klass->init = segAbsInit;
   klass->setSummary = segNoSetSummary; 
   klass->buffer = segNoBuffer; 
   klass->setBuffer = segNoSetBuffer;
@@ -1648,6 +1679,21 @@ DEFINE_CLASS(Seg, GCSeg, klass)
 }
 
 
+/* MutatorSegClass -- collectable mutator segment class definition */
+
+typedef SegClassStruct MutatorSegClassStruct;
+
+DEFINE_CLASS(Seg, MutatorSeg, klass)
+{
+  INHERIT_CLASS(klass, MutatorSeg, GCSeg);
+  klass->setSummary = mutatorSegSetSummary; 
+  klass->setGrey = mutatorSegSetGrey;
+  klass->setRankSet = mutatorSegSetRankSet;
+  klass->setRankSummary = mutatorSegSetRankSummary;
+  AVERT(SegClass, klass);
+}
+
+
 /* SegClassMixInNoSplitMerge -- Mix-in for unsupported merge
  *
  * Classes which don't support segment splitting and merging
diff --git a/mps/design/poolamc.txt b/mps/design/poolamc.txt
index 97e15fc8a8b..da80febdecd 100644
--- a/mps/design/poolamc.txt
+++ b/mps/design/poolamc.txt
@@ -350,7 +350,10 @@ Segments
 --------
 
 _`.seg.class`: AMC allocates segments of class ``AMCSegClass``, which
-is a subclass of ``GCSegClass``.
+is a subclass of ``MutatorSegClass`` (see
+design.mps.seg.over.hierarchy.mutatorseg_).
+
+.. _design.mps.seg.over.hierarchy.mutatorseg: seg#over-hierarchy-mutatorseg
 
 _`.seg.gen`: AMC organizes the segments it manages into generations.
 
diff --git a/mps/design/poolawl.txt b/mps/design/poolawl.txt
index a47854df285..d6d3cf7d0e7 100644
--- a/mps/design/poolawl.txt
+++ b/mps/design/poolawl.txt
@@ -158,9 +158,9 @@ _`.poolstruct.gen.1`: At the moment the ``gen`` field is set for all
 AWL pools to be 1.
 
 _`.awlseg`: The pool defines a segment class ``AWLSegClass``, which is
-a subclass of ``GCSegClass`` (see
-design.mps.seg.over.hierarchy.gcseg_). All segments allocated by the
-pool are instances of this class, and are of type ``AWLSeg``, for
+a subclass of ``MutatorSegClass`` (see
+design.mps.seg.over.hierarchy.mutatorseg_). All segments allocated by
+the pool are instances of this class, and are of type ``AWLSeg``, for
 which the structure is::
 
     struct AWLSegStruct {
@@ -175,7 +175,7 @@ which the structure is::
       Sig sig;
     }
 
-.. _design.mps.seg.over.hierarchy.gcseg: seg#over-hierarchy-gcseg
+.. _design.mps.seg.over.hierarchy.mutatorseg: seg#over-hierarchy-mutatorseg
 
 _`.awlseg.bt`: The mark, alloc, and scanned fields are bit-tables (see
 design.mps.bt_). Each bit in the table corresponds to a a single
diff --git a/mps/design/poollo.txt b/mps/design/poollo.txt
index aae70799452..700140a292d 100644
--- a/mps/design/poollo.txt
+++ b/mps/design/poollo.txt
@@ -129,8 +129,12 @@ computations. It is ``SizeLog2(pool->alignment).`` It can be used on
 the right of a shift operator (``<<`` or ``>>``) to convert between a
 number of bytes and a number of grains.
 
-_`.loseg`: Every segment is an instance of segment class ``LOSegClass``, a
-subclass of ``GCSegClass``, and is an object of type ``LOSegStruct``.
+_`.loseg`: Every segment is an instance of segment class
+``LOSegClass``, a subclass of ``MutatorSegClass`` (see
+design.mps.seg.over.hierarchy.mutatorseg_), and is an object of type
+``LOSegStruct``.
+
+.. _design.mps.seg.over.hierarchy.mutatorseg: seg#over-hierarchy-mutatorseg
 
 _`.loseg.purpose`: The purpose of the ``LOSeg`` structure is to
 associate the bit tables used for recording allocation and mark
diff --git a/mps/design/poolmrg.txt b/mps/design/poolmrg.txt
index dd536210148..d53a203fd81 100644
--- a/mps/design/poolmrg.txt
+++ b/mps/design/poolmrg.txt
@@ -336,7 +336,7 @@ the latter will be used to store the link parts of guardians (see
 one of each class, by the function ``MRGSegPairCreate()``. Each
 segment contains a link to its pair.
 
-_`.mrgseg.ref`: ``MRGRefSegClass`` is a subclass of ``GCSegClass``.
+_`.mrgseg.ref`: ``MRGRefSegClass`` is a subclass of ``MutatorSegClass``.
 Instances are of type ``MRGRefSeg``, and contain:
 
 - _`.mrgseg.ref.mrgring`: a field for the ring of ref part segments in
diff --git a/mps/design/seg.txt b/mps/design/seg.txt
index bec102453f9..70c62a2c7dd 100644
--- a/mps/design/seg.txt
+++ b/mps/design/seg.txt
@@ -51,9 +51,15 @@ subclass with additional properties.
 
 .. _design.mps.protocol: protocol
 
-_`.over.hierarchy.gcseg`: The segment module provides ``GCSeg`` - a
-subclass of ``Seg`` which has full support for GC including buffering
-and the ability to be linked onto the grey ring.
+_`.over.hierarchy.gcseg`: ``GCSeg`` is a subclass of ``Seg`` which
+implements garbage collection, including buffering and the ability to
+be linked onto the grey ring. It does not implement hardware barriers,
+and so can only be used with software barriers, for example internally
+in the MPS.
+
+_`.over.hierarchy.mutatorseg`: ``MutatorSeg`` is a subclass of
+``GCSeg`` implementing hardware barriers. It is suitable for handing
+out to the mutator.
 
 
 Data Structure

From e93949aeef05b7282beca72c97cd2c34573833cc Mon Sep 17 00:00:00 2001
From: Gareth Rees <gdr@ravenbrook.com>
Date: Tue, 19 Jun 2018 16:25:52 +0100
Subject: [PATCH 4/6] Refactor arenapeekseg so that it maintains the mps
 invariants by scanning the segment if necessary. arenaread is now a thin
 wrapper around arenapeekseg. new function arenawrite is now the corresponding
 wrapper around arenapokeseg.

MRG reference segments inherit from GCSeg (not MutatorSeg) and so don't have hardware barriers. Instead, the code implements software barriers by always using ArenaRead and ArenaWrite.

Copied from Perforce
 Change: 193990
---
 mps/code/global.c       | 143 ++++++++++++++++++++++------------------
 mps/code/mpm.h          |  29 ++++----
 mps/code/poolmrg.c      |  11 ++--
 mps/code/seg.c          |   6 +-
 mps/design/finalize.txt |  27 ++------
 5 files changed, 104 insertions(+), 112 deletions(-)

diff --git a/mps/code/global.c b/mps/code/global.c
index aab86d2dcc4..1ff5ac8f151 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -871,7 +871,7 @@ Res ArenaDefinalize(Arena arena, Ref obj)
 }
 
 
-/* Peek / Poke */
+/* ArenaPeek -- read a single reference, possibly through a barrier */
 
 Ref ArenaPeek(Arena arena, Ref *p)
 {
@@ -888,74 +888,19 @@ Ref ArenaPeek(Arena arena, Ref *p)
   return ref;
 }
 
+/* ArenaPeekSeg -- as ArenaPeek, but p must be in seg. */
+
 Ref ArenaPeekSeg(Arena arena, Seg seg, Ref *p)
 {
   Ref ref;
-
-  AVERT(Arena, arena);
-  AVERT(Seg, seg);
-
-  AVER(SegBase(seg) <= (Addr)p);
-  AVER((Addr)p < SegLimit(seg));
-  /* TODO: Consider checking p's alignment using seg->pool->alignment */
-
-  ShieldExpose(arena, seg);
-  ref = *p;
-  ShieldCover(arena, seg);
-  return ref;
-}
-
-void ArenaPoke(Arena arena, Ref *p, Ref ref)
-{
-  Seg seg;
-
-  AVERT(Arena, arena);
-  /* Can't check p as it is arbitrary */
-  /* Can't check ref as it is arbitrary */
-
-  if (SegOfAddr(&seg, arena, (Addr)p))
-    ArenaPokeSeg(arena, seg, p, ref);
-  else
-    *p = ref;
-}
-
-void ArenaPokeSeg(Arena arena, Seg seg, Ref *p, Ref ref)
-{
-  RefSet summary;
-
-  AVERT(Arena, arena);
-  AVERT(Seg, seg);
-  AVER(SegBase(seg) <= (Addr)p);
-  AVER((Addr)p < SegLimit(seg));
-  /* TODO: Consider checking p's alignment using seg->pool->alignment */
-  /* ref is arbitrary and can't be checked */
-
-  ShieldExpose(arena, seg);
-  *p = ref;
-  summary = SegSummary(seg);
-  summary = RefSetAdd(arena, summary, (Addr)ref);
-  SegSetSummary(seg, summary);
-  ShieldCover(arena, seg);
-}
-
-
-/* ArenaRead -- read a single reference, possibly through a barrier
- *
- * This forms part of a software barrier.  It provides fine-grain access
- * to single references in segments.
- * 
- * See also PoolSingleAccess and PoolSegAccess. */
-
-Ref ArenaRead(Arena arena, Ref *p)
-{
-  Bool b;
-  Seg seg = NULL;       /* suppress "may be used uninitialized" */
   Rank rank;
 
   AVERT(Arena, arena);
-
-  b = SegOfAddr(&seg, arena, (Addr)p);
-  AVER(b == TRUE);
+  AVERT(Seg, seg);
+  AVER(PoolArena(SegPool(seg)) == arena);
+  AVER(SegBase(seg) <= (Addr)p);
+  AVER((Addr)p < SegLimit(seg));
+  /* TODO: Consider checking p's alignment using seg->pool->alignment */
 
   /* .read.flipped: We AVER that the reference that we are reading */
   /* refers to an object for which all the traces that the object is */
@@ -977,11 +922,81 @@ Ref ArenaRead(Arena arena, Ref *p)
 
   /* We don't need to update the Seg Summary as in PoolSingleAccess
    * because we are not changing it after it has been scanned. */
+
+  ShieldExpose(arena, seg);
+  ref = *p;
+  ShieldCover(arena, seg);
+  return ref;
+}
+
+/* ArenaPoke -- write a single reference, possibly through a barrier */
+
+void ArenaPoke(Arena arena, Ref *p, Ref ref)
+{
+  Seg seg;
+
+  AVERT(Arena, arena);
+  /* Can't check p as it is arbitrary */
+  /* Can't check ref as it is arbitrary */
+
+  if (SegOfAddr(&seg, arena, (Addr)p))
+    ArenaPokeSeg(arena, seg, p, ref);
+  else
+    *p = ref;
+}
+
+/* ArenaPokeSeg -- as ArenaPoke, but p must be in seg. */
+
+void ArenaPokeSeg(Arena arena, Seg seg, Ref *p, Ref ref)
+{
+  RefSet summary;
+
+  AVERT(Arena, arena);
+  AVERT(Seg, seg);
+  AVER(PoolArena(SegPool(seg)) == arena);
+  AVER(SegBase(seg) <= (Addr)p);
+  AVER((Addr)p < SegLimit(seg));
+  /* TODO: Consider checking p's alignment using seg->pool->alignment */
+  /* ref is arbitrary and can't be checked */
+
+  ShieldExpose(arena, seg);
+  *p = ref;
+  summary = SegSummary(seg);
+  summary = RefSetAdd(arena, summary, (Addr)ref);
+  SegSetSummary(seg, summary);
+  ShieldCover(arena, seg);
+}
+
+/* ArenaRead -- like ArenaPeek, but reference known to be owned by arena */
+
+Ref ArenaRead(Arena arena, Ref *p)
+{
+  Bool b;
+  Seg seg = NULL;       /* suppress "may be used uninitialized" */
+
+  AVERT(Arena, arena);
+
+  b = SegOfAddr(&seg, arena, (Addr)p);
+  AVER(b == TRUE);
   
-  /* get the possibly fixed reference */
   return ArenaPeekSeg(arena, seg, p);
 }
 
+/* ArenaWrite -- like ArenaPoke, but reference known to be owned by arena */
+
+void ArenaWrite(Arena arena, Ref *p, Ref ref)
+{
+  Bool b;
+  Seg seg = NULL;       /* suppress "may be used uninitialized" */
+
+  AVERT(Arena, arena);
+
+  b = SegOfAddr(&seg, arena, (Addr)p);
+  AVER(b == TRUE);
+  
+  ArenaPokeSeg(arena, seg, p, ref);
+}
+
 
 /* GlobalsDescribe -- describe the arena globals */
 
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index 4bb6638abbf..a031792ffc4 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -563,37 +563,32 @@ extern void ControlFree(Arena arena, void *base, size_t size);
 extern Res ControlDescribe(Arena arena, mps_lib_FILE *stream, Count depth);
 
 
-/* Peek/Poke
+/* Peek/Poke/Read/Write -- read/write possibly through barrier
  *
  * These are provided so that modules in the MPS can make occasional
- * access to client data.  They perform the appropriate shield and
- * summary manipulations that are necessary.
+ * access to client data, and to implement a software barrier for
+ * segments that are not handed out to the mutator. They protect the
+ * necessary colour, shield and summary invariants.
  *
- * Note that Peek and Poke can be called with address that may or
- * may not be in arena managed memory.  */
+ * Note that Peek and Poke can be called with an address that may or
+ * may not be in memory managed by arena, whereas Read and Write
+ * assert this is the case.
+ */
 
 /* Peek reads a value */
 extern Ref ArenaPeek(Arena arena, Ref *p);
+/* Same, but p known to be owned by arena */
+extern Ref ArenaRead(Arena arena, Ref *p);
 /* Same, but p must be in seg */
 extern Ref ArenaPeekSeg(Arena arena, Seg seg, Ref *p);
 /* Poke stores a value */
 extern void ArenaPoke(Arena arena, Ref *p, Ref ref);
+/* Same, but p known to be owned by arena */
+extern void ArenaWrite(Arena arena, Ref *p, Ref ref);
 /* Same, but p must be in seg */
 extern void ArenaPokeSeg(Arena arena, Seg seg, Ref *p, Ref ref);
 
 
-/* Read/Write
- *
- * These simulate mutator reads and writes to locations.
- * They are effectively a software barrier, and maintain the tricolor
- * invariant (hence performing any scanning or color manipulation
- * necessary).
- *
- * Only Read provided right now.  */
-
-Ref ArenaRead(Arena arena, Ref *p);
-
-
 extern Size ArenaReserved(Arena arena);
 extern Size ArenaCommitted(Arena arena);
 extern Size ArenaSpareCommitted(Arena arena);
diff --git a/mps/code/poolmrg.c b/mps/code/poolmrg.c
index 12bbf6b2953..a54758c5599 100644
--- a/mps/code/poolmrg.c
+++ b/mps/code/poolmrg.c
@@ -74,7 +74,8 @@ typedef struct RefPartStruct {
 } RefPartStruct;
 
 
-/* MRGRefPartRef,MRGRefPartSetRef -- Peek and poke the reference
+/* MRGRefPartRef,MRGRefPartSetRef -- read and write the reference
+ * using the software barrier
  *
  * Might be more efficient to take a seg, rather than calculate it
  * every time.
@@ -87,7 +88,7 @@ static Ref MRGRefPartRef(Arena arena, RefPart refPart)
 
   AVER(refPart != NULL);
 
-  ref = ArenaPeek(arena, &refPart->ref);
+  ref = ArenaRead(arena, &refPart->ref);
   return ref;
 }
 
@@ -102,7 +103,7 @@ static void MRGRefPartSetRef(Arena arena, RefPart refPart, Ref ref)
 {
   AVER(refPart != NULL);
 
-  ArenaPoke(arena, &refPart->ref, ref);
+  ArenaWrite(arena, &refPart->ref, ref);
 }
 
 
@@ -166,7 +167,7 @@ typedef struct MRGRefSegStruct {
 /* forward declarations */
 
 DECLARE_CLASS(Seg, MRGLinkSeg, Seg);
-DECLARE_CLASS(Seg, MRGRefSeg, MutatorSeg);
+DECLARE_CLASS(Seg, MRGRefSeg, GCSeg);
 
 
 /* MRGLinkSegCheck -- check a link segment
@@ -296,7 +297,7 @@ DEFINE_CLASS(Seg, MRGLinkSeg, klass)
 
 DEFINE_CLASS(Seg, MRGRefSeg, klass)
 {
-  INHERIT_CLASS(klass, MRGRefSeg, MutatorSeg);
+  INHERIT_CLASS(klass, MRGRefSeg, GCSeg);
   SegClassMixInNoSplitMerge(klass);  /* no support for this */
   klass->size = sizeof(MRGRefSegStruct);
   klass->init = MRGRefSegInit;
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 5177913ea3c..3debf913d67 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -1247,7 +1247,7 @@ static void gcSegSetWhite(Seg seg, TraceSet white)
     AVER_CRITICAL(trseg == seg);
     TractSetWhite(tract, BS_BITFIELD(Trace, white));
   }
-  AVER(addr == limit);
+  AVER_CRITICAL(addr == limit);
 
   seg->white = BS_BITFIELD(Trace, white);
 }
@@ -1339,7 +1339,7 @@ static void gcSegSetSummary(Seg seg, RefSet summary)
 
   gcseg->summary = summary;
 
-  AVER(seg->rankSet != RankSetEMPTY);
+  AVER_CRITICAL(seg->rankSet != RankSetEMPTY);
 }
 
 
@@ -1371,7 +1371,7 @@ static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
   AVER_CRITICAL(&gcseg->segStruct == seg);
 
   /* rankSet == RankSetEMPTY implies summary == RefSetEMPTY */
-  AVER(rankSet != RankSetEMPTY || summary == RefSetEMPTY);
+  AVER_CRITICAL(rankSet != RankSetEMPTY || summary == RefSetEMPTY);
 
   seg->rankSet = BS_BITFIELD(Rank, rankSet);
   gcseg->summary = summary;
diff --git a/mps/design/finalize.txt b/mps/design/finalize.txt
index f75cb3ccd24..65f82562494 100644
--- a/mps/design/finalize.txt
+++ b/mps/design/finalize.txt
@@ -74,30 +74,11 @@ then ``ArenaDestroy()`` destroys the final pool.
 _`.impl.access`: ``mps_message_finalization_ref()`` needs to access
 the finalization message to retrieve the reference and then write it
 to where the client asks. This must be done carefully, in order to
-avoid hitting the write barrier or invalidating collection invariants
-such as the segment summary.
+avoid invalidating collection invariants such as the segment summary.
 
-_`.impl.invariants`: We protect the invariants by using special
-routines ``ArenaRead()`` and ``ArenaPoke()`` to read and write the
-reference. This works as long as there's no write-barrier collection.
-
-.. note::
-
-    Instead of ``ArenaPoke()``, we could put in an ``ArenaWrite()``
-    that would be identical to ``ArenaPoke()``, except that it would
-    ``AVER()`` the invariant (or it can just ``AVER()`` that there are
-    no busy traces unflipped). When we get write-barrier collection,
-    we could change it to do the real thing, but in the absence of a
-    write-barrier, it's functionally identical to ``ArenaPoke()``.
-    Pekka P. Pirinen, 1997-12-09.
-
-.. note::
-
-    There is no need to maintain a write barrier on segments belonging
-    to the MRG pool, as these segments are never given to the mutator.
-    See job004030_.
-
-    .. _job004030: https://www.ravenbrook.com/project/mps/issue/job004030/
+_`.impl.invariants`: We protect the invariants by using
+``ArenaRead()`` and ``ArenaWrite()`` to read and write the reference
+via the software barrier.
 
 
 External interface

From a5ddfca39b5f0a3ec02da9bbf84963ec7c29cdf4 Mon Sep 17 00:00:00 2001
From: Gareth Rees <gdr@ravenbrook.com>
Date: Wed, 20 Jun 2018 10:23:16 +0100
Subject: [PATCH 5/6] =?UTF-8?q?New=20generic=20function=20segflip=20allows?=
 =?UTF-8?q?=20the=20segment=20to=20decide=20how=20to=20handle=20a=20trace?=
 =?UTF-8?q?=20that=E2=80=99s=20about=20to=20flip.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Copied from Perforce
 Change: 194000
---
 mps/code/mpm.h      |  1 +
 mps/code/mpmst.h    |  1 +
 mps/code/mpmtypes.h |  1 +
 mps/code/seg.c      | 49 +++++++++++++++++++++++++++++++++++++++++++++
 mps/code/trace.c    |  8 ++------
 mps/design/seg.txt  | 10 +++++++++
 6 files changed, 64 insertions(+), 6 deletions(-)

diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index a031792ffc4..2ecef0b1852 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -658,6 +658,7 @@ extern Bool SegNext(Seg *segReturn, Arena arena, Seg seg);
 extern Bool SegNextOfRing(Seg *segReturn, Arena arena, Pool pool, Ring next);
 extern void SegSetWhite(Seg seg, TraceSet white);
 extern void SegSetGrey(Seg seg, TraceSet grey);
+extern void SegFlip(Seg seg, Trace trace);
 extern void SegSetRankSet(Seg seg, RankSet rankSet);
 extern void SegSetRankAndSummary(Seg seg, RankSet rankSet, RefSet summary);
 extern Res SegMerge(Seg *mergedSegReturn, Seg segLo, Seg segHi);
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 57e0f4a24cc..c63ca4320f1 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -223,6 +223,7 @@ typedef struct SegClassStruct {
   SegSetBufferMethod setBuffer; /* set the segment buffer  */
   SegUnsetBufferMethod unsetBuffer; /* unset the segment buffer */
   SegSetGreyMethod setGrey;     /* change greyness of segment */
+  SegFlipMethod flip;           /* raise barrier for a flipped trace */
   SegSetWhiteMethod setWhite;   /* change whiteness of segment */
   SegSetRankSetMethod setRankSet; /* change rank set of segment */
   SegSetRankSummaryMethod setRankSummary; /* change rank set & summary */
diff --git a/mps/code/mpmtypes.h b/mps/code/mpmtypes.h
index 9d6e54c990e..15786d6244a 100644
--- a/mps/code/mpmtypes.h
+++ b/mps/code/mpmtypes.h
@@ -152,6 +152,7 @@ typedef void (*FreeBlockVisitor)(Addr base, Addr limit, Pool pool, void *p);
 typedef Res (*SegInitMethod)(Seg seg, Pool pool, Addr base, Size size,
                              ArgList args);
 typedef void (*SegSetGreyMethod)(Seg seg, TraceSet grey);
+typedef void (*SegFlipMethod)(Seg seg, Trace trace);
 typedef void (*SegSetWhiteMethod)(Seg seg, TraceSet white);
 typedef void (*SegSetRankSetMethod)(Seg seg, RankSet rankSet);
 typedef void (*SegSetRankSummaryMethod)(Seg seg, RankSet rankSet,
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 3debf913d67..b5b2a46b76a 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -257,6 +257,20 @@ void SegSetGrey(Seg seg, TraceSet grey)
 }
 
 
+/* SegFlip -- update barriers for trace that's about to flip */
+
+void SegFlip(Seg seg, Trace trace)
+{
+  AVERT(Seg, seg);
+  AVERT(Trace, trace);
+
+  /* Don't dispatch to the class method unless the segment is grey for
+     the trace that's about to flip, and contains references. */
+  if (TraceSetIsMember(SegGrey(seg), trace) && SegRankSet(seg) != RankSetEMPTY)
+    Method(Seg, seg, flip)(seg, trace);
+}
+
+
 /* SegSetWhite -- change the whiteness of a segment
  *
  * Sets the segment whiteness to the trace set ts.
@@ -788,6 +802,16 @@ static void segNoSetGrey(Seg seg, TraceSet grey)
 }
 
 
+/* segTrivFlip -- ignore trace that's about to flip */
+
+static void segTrivFlip(Seg seg, Trace trace)
+{
+  AVERT(Seg, seg);
+  AVERT(Trace, trace);
+  AVER(seg->rankSet != RankSetEMPTY);
+}
+
+
 /* segNoSetWhite -- non-method to change the whiteness of a segment */
 
 static void segNoSetWhite(Seg seg, TraceSet white)
@@ -1216,6 +1240,29 @@ static void mutatorSegSetGrey(Seg seg, TraceSet grey)
   }
 }
 
+/* mutatorSegFlip -- update barriers for a trace that's about to flip */
+
+static void mutatorSegFlip(Seg seg, Trace trace)
+{
+  TraceSet flippedTraces;
+  Arena arena;
+
+  NextMethod(Seg, MutatorSeg, flip)(seg, trace);
+
+  /* Raise the read barrier if the segment was not grey for any
+     currently flipped trace. */
+  arena = PoolArena(SegPool(seg));
+  flippedTraces = arena->flippedTraces;
+  if (TraceSetInter(SegGrey(seg), flippedTraces) == TraceSetEMPTY) {
+    ShieldRaise(arena, seg, AccessREAD);
+  } else {
+    /* If the segment is grey for some currently flipped trace then
+       the read barrier must already have been raised, either in this
+       method or in mutatorSegSetGrey. */
+    AVER(SegSM(seg) & AccessREAD);
+  }
+}
+
 
 /* gcSegSetWhite -- GCSeg method to change whiteness of a segment
  *
@@ -1644,6 +1691,7 @@ DEFINE_CLASS(Seg, Seg, klass)
   klass->setBuffer = segNoSetBuffer;
   klass->unsetBuffer = segNoUnsetBuffer;
   klass->setGrey = segNoSetGrey;
+  klass->flip = segTrivFlip;
   klass->setWhite = segNoSetWhite;
   klass->setRankSet = segNoSetRankSet;
   klass->setRankSummary = segNoSetRankSummary;
@@ -1688,6 +1736,7 @@ DEFINE_CLASS(Seg, MutatorSeg, klass)
   INHERIT_CLASS(klass, MutatorSeg, GCSeg);
   klass->setSummary = mutatorSegSetSummary; 
   klass->setGrey = mutatorSegSetGrey;
+  klass->flip = mutatorSegFlip;
   klass->setRankSet = mutatorSegSetRankSet;
   klass->setRankSummary = mutatorSegSetRankSummary;
   AVERT(SegClass, klass);
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 33f94efb55d..0a493e89bdb 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -590,15 +590,11 @@ static Res traceFlip(Trace trace)
   /* drj 2003-02-19) */
 
   /* Now that the mutator is black we must prevent it from reading */
-  /* grey objects so that it can't obtain white pointers.  This is */
-  /* achieved by read protecting all segments containing objects */
-  /* which are grey for any of the flipped traces. */
+  /* grey objects so that it can't obtain white pointers. */
   for(rank = RankMIN; rank < RankLIMIT; ++rank)
     RING_FOR(node, ArenaGreyRing(arena, rank), nextNode) {
       Seg seg = SegOfGreyRing(node);
-      if(TraceSetInter(SegGrey(seg), arena->flippedTraces) == TraceSetEMPTY
-          && TraceSetIsMember(SegGrey(seg), trace))
-        ShieldRaise(arena, seg, AccessREAD);
+      SegFlip(seg, trace);
     }
 
   /* @@@@ When write barrier collection is implemented, this is where */
diff --git a/mps/design/seg.txt b/mps/design/seg.txt
index 70c62a2c7dd..e4f64404dbc 100644
--- a/mps/design/seg.txt
+++ b/mps/design/seg.txt
@@ -233,6 +233,16 @@ of ``segLo`` and ``segHi``.
 Extensibility
 -------------
 
+Garbage collection
+..................
+
+``typedef void (*SegFlipMethod)(Seg seg, Trace trace)``
+
+_`.method.flip`: Raise the read barrier, if necessary, for a trace
+that's about to flip and for which the segment is grey and potentially
+contains references.
+
+
 Splitting and merging
 .....................
 

From 1d7bfe10fb89d34497bc7b6e980513b25418c898 Mon Sep 17 00:00:00 2001
From: Gareth Rees <gdr@ravenbrook.com>
Date: Wed, 20 Jun 2018 11:06:01 +0100
Subject: [PATCH 6/6] Add a check that the flipped trace was not already
 flipped.

Copied from Perforce
 Change: 194006
---
 mps/code/seg.c | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/mps/code/seg.c b/mps/code/seg.c
index b5b2a46b76a..ca8e4b4a16a 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -1249,10 +1249,12 @@ static void mutatorSegFlip(Seg seg, Trace trace)
 
   NextMethod(Seg, MutatorSeg, flip)(seg, trace);
 
-  /* Raise the read barrier if the segment was not grey for any
-     currently flipped trace. */
   arena = PoolArena(SegPool(seg));
   flippedTraces = arena->flippedTraces;
+  AVER(!TraceSetIsMember(flippedTraces, trace));
+
+  /* Raise the read barrier if the segment was not grey for any
+     currently flipped trace. */
   if (TraceSetInter(SegGrey(seg), flippedTraces) == TraceSetEMPTY) {
     ShieldRaise(arena, seg, AccessREAD);
   } else {