From e05a3f745513b6b5b85d50c798e67dde294c5074 Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Mon, 18 Aug 2014 10:42:47 +0100
Subject: [PATCH 01/69] Branching master to branch/2014-08-18/non-incremental.

Copied from Perforce
 Change: 186962
 ServerID: perforce.ravenbrook.com

From 858954c95e802e8b790039f083d3eb8110ca34ea Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Mon, 18 Aug 2014 12:06:03 +0100
Subject: [PATCH 02/69] Collections now non-incremental. simple change to
 tracepoll to make collections do work until they are finished.

Copied from Perforce
 Change: 186964
 ServerID: perforce.ravenbrook.com
---
 mps/code/trace.c | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/mps/code/trace.c b/mps/code/trace.c
index 163d8b63a39..71d062a3e45 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1817,6 +1817,7 @@ Size TracePoll(Globals globals)
   Res res;
   Arena arena;
   Size scannedSize;
+  Bool incremental = FALSE;
 
   AVERT(Globals, globals);
   arena = GlobalsArena(globals);
@@ -1888,7 +1889,9 @@ Size TracePoll(Globals globals)
     trace = ArenaTrace(arena, (TraceId)0);
     AVER(arena->busyTraces == TraceSetSingle(trace));
     oldScanned = traceWorkClock(trace);
-    TraceQuantum(trace);
+    do {
+      TraceQuantum(trace);
+    } while(!incremental && trace->state != TraceFINISHED);
     scannedSize = traceWorkClock(trace) - oldScanned;
     if(trace->state == TraceFINISHED) {
       TraceDestroy(trace);

From 8c9353fe341b62437b43a61b46315b373ed73535 Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Wed, 20 Aug 2014 13:03:20 +0100
Subject: [PATCH 03/69] Add mps_key_arena_incremental option.

Avoid read and write barrier in non-incremental mode.
Add --non-incremental option to gcbench

Copied from Perforce
 Change: 186969
 ServerID: perforce.ravenbrook.com
---
 mps/code/arena.c   |  6 ++++++
 mps/code/config.h  |  2 ++
 mps/code/gcbench.c | 10 +++++++++-
 mps/code/mpmst.h   |  1 +
 mps/code/mps.h     |  3 +++
 mps/code/seg.c     | 17 +++++++++--------
 mps/code/trace.c   | 22 +++++++++++++---------
 7 files changed, 43 insertions(+), 18 deletions(-)

diff --git a/mps/code/arena.c b/mps/code/arena.c
index afff836f647..dab6f300349 100644
--- a/mps/code/arena.c
+++ b/mps/code/arena.c
@@ -193,6 +193,7 @@ Res ArenaInit(Arena arena, ArenaClass class, Size grainSize, ArgList args)
 {
   Res res;
   Bool zoned = ARENA_DEFAULT_ZONED;
+  Bool incremental = ARENA_DEFAULT_INCREMENTAL;
   mps_arg_s arg;
 
   AVER(arena != NULL);
@@ -202,6 +203,9 @@ Res ArenaInit(Arena arena, ArenaClass class, Size grainSize, ArgList args)
   if (ArgPick(&arg, args, MPS_KEY_ARENA_ZONED))
     zoned = arg.val.b;
 
+  if (ArgPick(&arg, args, MPS_KEY_ARENA_INCREMENTAL))
+    incremental = arg.val.b;
+
   arena->class = class;
 
   arena->committed = (Size)0;
@@ -219,6 +223,7 @@ Res ArenaInit(Arena arena, ArenaClass class, Size grainSize, ArgList args)
   arena->hasFreeLand = FALSE;
   arena->freeZones = ZoneSetUNIV;
   arena->zoned = zoned;
+  arena->incremental = incremental;
 
   arena->primary = NULL;
   RingInit(&arena->chunkRing);
@@ -296,6 +301,7 @@ ARG_DEFINE_KEY(vmw3_top_down, Bool);
 ARG_DEFINE_KEY(arena_size, Size);
 ARG_DEFINE_KEY(arena_grain_size, Size);
 ARG_DEFINE_KEY(arena_zoned, Bool);
+ARG_DEFINE_KEY(arena_incremental, Bool);
 
 Res ArenaCreate(Arena *arenaReturn, ArenaClass class, ArgList args)
 {
diff --git a/mps/code/config.h b/mps/code/config.h
index c0441d1050c..ac5d7a849ec 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -408,6 +408,8 @@
 
 #define ARENA_DEFAULT_ZONED     TRUE
 
+#define ARENA_DEFAULT_INCREMENTAL     TRUE
+
 #define ArenaDefaultZONESET (ZoneSetUNIV << (MPS_WORD_WIDTH / 2))
 /* TODO: This is left over from before the branch/2014-01-29/mps-chain-zones
    and 2014-01-17/cbs-tract-alloc reformed allocation, and may now be doing
diff --git a/mps/code/gcbench.c b/mps/code/gcbench.c
index 0dc3ef3ded8..3bc1a7ef8eb 100644
--- a/mps/code/gcbench.c
+++ b/mps/code/gcbench.c
@@ -50,6 +50,7 @@ static size_t arena_size = 256ul * 1024 * 1024; /* arena size */
 static size_t arena_grain_size = 1; /* arena grain size */
 static unsigned pinleaf = FALSE;  /* are leaf objects pinned at start */
 static mps_bool_t zoned = TRUE;   /* arena allocates using zones */
+static mps_bool_t incremental = TRUE; /* arena allocates using zones */
 
 typedef struct gcthread_s *gcthread_t;
 
@@ -231,6 +232,7 @@ static void arena_setup(gcthread_fn_t fn,
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, arena_size);
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, zoned);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_INCREMENTAL, incremental);
     RESMUST(mps_arena_create_k(&arena, mps_arena_class_vm(), args));
   } MPS_ARGS_END(args);
   RESMUST(dylan_fmt(&format, arena));
@@ -274,6 +276,7 @@ static struct option longopts[] = {
   {"pin-leaf",         no_argument,       NULL, 'l'},
   {"seed",             required_argument, NULL, 'x'},
   {"arena-unzoned",    no_argument,       NULL, 'z'},
+  {"non-incremental",  no_argument,       NULL, 'I'},
   {NULL,               0,                 NULL, 0  }
 };
 
@@ -303,7 +306,7 @@ int main(int argc, char *argv[]) {
   }
   putchar('\n');
   
-  while ((ch = getopt_long(argc, argv, "ht:i:p:g:m:a:w:d:r:u:lx:z", longopts, NULL)) != -1)
+  while ((ch = getopt_long(argc, argv, "ht:i:p:g:m:a:w:d:r:u:lx:zI", longopts, NULL)) != -1)
     switch (ch) {
     case 't':
       nthreads = (unsigned)strtoul(optarg, NULL, 10);
@@ -392,6 +395,9 @@ int main(int argc, char *argv[]) {
     case 'z':
       zoned = FALSE;
       break;
+    case 'I':
+      incremental = FALSE;
+      break;
     default:
       /* This is printed in parts to keep within the 509 character
          limit for string literals in portable standard C. */
@@ -437,6 +443,8 @@ int main(int argc, char *argv[]) {
       fprintf(stderr,
               "  -z, --arena-unzoned\n"
               "    Disable zoned allocation in the arena\n"
+              "  -I, --non-incremental\n"
+              "    Disable incremental collection\n"
               "Tests:\n"
               "  amc   pool class AMC\n"
               "  ams   pool class AMS\n");
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 50945d573d4..219858f0f54 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -741,6 +741,7 @@ typedef struct mps_arena_s {
   CBSStruct freeLandStruct;
   ZoneSet freeZones;            /* zones not yet allocated */
   Bool zoned;                   /* use zoned allocation? */
+  Bool incremental;             /* perform gc incrementally */
 
   /* locus fields (<code/locus.c>) */
   GenDescStruct topGen;         /* generation descriptor for dynamic gen */
diff --git a/mps/code/mps.h b/mps/code/mps.h
index 758c1b389b4..fc1fb0fcd57 100644
--- a/mps/code/mps.h
+++ b/mps/code/mps.h
@@ -163,6 +163,9 @@ extern const struct mps_key_s _mps_key_arena_grain_size;
 extern const struct mps_key_s _mps_key_arena_zoned;
 #define MPS_KEY_ARENA_ZONED     (&_mps_key_arena_zoned)
 #define MPS_KEY_ARENA_ZONED_FIELD b
+extern const struct mps_key_s _mps_key_arena_incremental;
+#define MPS_KEY_ARENA_INCREMENTAL     (&_mps_key_arena_incremental)
+#define MPS_KEY_ARENA_INCREMENTAL_FIELD b
 extern const struct mps_key_s _mps_key_format;
 #define MPS_KEY_FORMAT          (&_mps_key_format)
 #define MPS_KEY_FORMAT_FIELD    format
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 212b1f2baa7..ef930071850 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -1207,17 +1207,18 @@ static void gcSegSetGrey(Seg seg, TraceSet grey)
   arena = PoolArena(SegPool(seg));
   oldGrey = seg->grey;
   gcSegSetGreyInternal(seg, oldGrey, grey); /* do the work */
-
   /* 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. */
-  flippedTraces = arena->flippedTraces;
-  if (TraceSetInter(oldGrey, flippedTraces) == TraceSetEMPTY) {
-    if (TraceSetInter(grey, flippedTraces) != TraceSetEMPTY)
-      ShieldRaise(arena, seg, AccessREAD);
-  } else {
-    if (TraceSetInter(grey, flippedTraces) == TraceSetEMPTY)
-      ShieldLower(arena, seg, AccessREAD);
+  if (arena->incremental) {
+    flippedTraces = arena->flippedTraces;
+    if (TraceSetInter(oldGrey, flippedTraces) == TraceSetEMPTY) {
+      if (TraceSetInter(grey, flippedTraces) != TraceSetEMPTY)
+        ShieldRaise(arena, seg, AccessREAD);
+    } else {
+      if (TraceSetInter(grey, flippedTraces) == TraceSetEMPTY)
+        ShieldLower(arena, seg, AccessREAD);
+    }
   }
 
   EVENT3(SegSetGrey, arena, seg, grey);
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 71d062a3e45..453977002cb 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -607,13 +607,14 @@ static Res traceFlip(Trace trace)
   /* 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. */
-  for(rank = 0; 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);
-    }
+  if (arena->incremental)
+    for (rank = 0; 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);
+      }
 
   /* @@@@ When write barrier collection is implemented, this is where */
   /* write protection should be removed for all segments which are */
@@ -1134,7 +1135,10 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
      * scan, consistent with the recorded SegSummary?
      */
     AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
+    
 
+    SegSetSummary(seg, RefSetUNIV);
+#if 0
     if(res != ResOK || !wasTotal) {
       /* scan was partial, so... */
       /* scanned summary should be ORed into segment summary. */
@@ -1144,6 +1148,7 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
       /* scanned summary should replace the segment summary. */
       SegSetSummary(seg, ScanStateSummary(ss));
     }
+#endif
 
     ScanStateFinish(ss);
   }
@@ -1817,7 +1822,6 @@ Size TracePoll(Globals globals)
   Res res;
   Arena arena;
   Size scannedSize;
-  Bool incremental = FALSE;
 
   AVERT(Globals, globals);
   arena = GlobalsArena(globals);
@@ -1891,7 +1895,7 @@ Size TracePoll(Globals globals)
     oldScanned = traceWorkClock(trace);
     do {
       TraceQuantum(trace);
-    } while(!incremental && trace->state != TraceFINISHED);
+    } while(!arena->incremental && trace->state != TraceFINISHED);
     scannedSize = traceWorkClock(trace) - oldScanned;
     if(trace->state == TraceFINISHED) {
       TraceDestroy(trace);

From 23174c0d801ba8c64a0bf9bf775009696d7bebf5 Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Thu, 21 Aug 2014 14:03:09 +0100
Subject: [PATCH 04/69] Use write barrier in incremental mode.

This was previously completely disabled.

Copied from Perforce
 Change: 186973
 ServerID: perforce.ravenbrook.com
---
 mps/code/trace.c | 22 +++++++++++-----------
 1 file changed, 11 insertions(+), 11 deletions(-)

diff --git a/mps/code/trace.c b/mps/code/trace.c
index 453977002cb..4f5b1477d81 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1136,19 +1136,19 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
      */
     AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
     
-
-    SegSetSummary(seg, RefSetUNIV);
-#if 0
-    if(res != ResOK || !wasTotal) {
-      /* scan was partial, so... */
-      /* scanned summary should be ORed into segment summary. */
-      SegSetSummary(seg, RefSetUnion(SegSummary(seg), ScanStateSummary(ss)));
+    if (arena->incremental) {
+      if(res != ResOK || !wasTotal) {
+        /* scan was partial, so... */
+        /* scanned summary should be ORed into segment summary. */
+        SegSetSummary(seg, RefSetUnion(SegSummary(seg), ScanStateSummary(ss)));
+      } else {
+        /* all objects on segment have been scanned, so... */
+        /* scanned summary should replace the segment summary. */
+        SegSetSummary(seg, ScanStateSummary(ss));
+      }
     } else {
-      /* all objects on segment have been scanned, so... */
-      /* scanned summary should replace the segment summary. */
-      SegSetSummary(seg, ScanStateSummary(ss));
+      SegSetSummary(seg, RefSetUNIV);
     }
-#endif
 
     ScanStateFinish(ss);
   }

From 46d723c9dcf134336fa6557a2995de82b26b5350 Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Thu, 21 Aug 2014 15:53:57 +0100
Subject: [PATCH 05/69] Added experimental control over write barrier
 eagerness.

The write barrier is only raised after three unnecessary scans.

Copied from Perforce
 Change: 186975
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h |  6 ++++++
 mps/code/mpmst.h  |  1 +
 mps/code/seg.c    |  1 +
 mps/code/trace.c  | 13 ++++++++++++-
 4 files changed, 20 insertions(+), 1 deletion(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index ac5d7a849ec..59a44ee3780 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -635,6 +635,12 @@
     { 36 * 1024, 0.45 }  /* second gen, after which dynamic */ \
   }
 
+/* Experimental Scan Barrier threshold
+ *
+ * The number of unecessary scans performed, before raising the write
+ * barrier to remember the refset summary.
+ */
+#define TRACE_SCAN_BARRIER_THRESHOLD 3
 
 #endif /* config_h */
 
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 219858f0f54..ba0be7aba58 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -300,6 +300,7 @@ typedef struct GCSegStruct {    /* GC segment structure */
   RingStruct greyRing;          /* link in list of grey segs */
   RefSet summary;               /* summary of references out of seg */
   Buffer buffer;                /* non-NULL if seg is buffered */
+  unsigned unnecessaryScans;    /* consecutive unnecessary scans performed */
   Sig sig;                      /* <design/sig/> */
 } GCSegStruct;
 
diff --git a/mps/code/seg.c b/mps/code/seg.c
index ef930071850..e5923c170f7 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -1082,6 +1082,7 @@ static Res gcSegInit(Seg seg, Pool pool, Addr base, Size size,
 
   gcseg->summary = RefSetEMPTY;
   gcseg->buffer = NULL;
+  gcseg->unnecessaryScans = 0;
   RingInit(&gcseg->greyRing);
   gcseg->sig = GCSegSig;
 
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 4f5b1477d81..bbe09b2d2c6 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1105,6 +1105,7 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
   } else {      /* scan it */
     ScanStateStruct ssStruct;
     ScanState ss = &ssStruct;
+    Bool considerBarrier = FALSE;
     ScanStateInit(ss, ts, arena, rank, white);
 
     /* Expose the segment to make sure we can scan it. */
@@ -1135,8 +1136,18 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
      * scan, consistent with the recorded SegSummary?
      */
     AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
+    if (ZoneSetInter(ScanStateUnfixedSummary(ss), white) == ZoneSetEMPTY) {
+      /* a scan was not necessary */
+      if (((GCSeg)seg)->unnecessaryScans < TRACE_SCAN_BARRIER_THRESHOLD) {
+        ((GCSeg)seg)->unnecessaryScans++;
+      } else {
+        considerBarrier = TRUE;
+      }
+    } else {
+      ((GCSeg)seg)->unnecessaryScans = 0;
+    }
     
-    if (arena->incremental) {
+    if (considerBarrier) {
       if(res != ResOK || !wasTotal) {
         /* scan was partial, so... */
         /* scanned summary should be ORed into segment summary. */

From b4460043e6a9f0fcc6b513094c68c3835a7b8b0d Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Wed, 27 Aug 2014 11:21:18 +0100
Subject: [PATCH 06/69] Added more control over write barrier. in particular
 separated scans after a hit.

Copied from Perforce
 Change: 186988
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h | 14 +++++++++++---
 mps/code/mpmst.h  |  2 +-
 mps/code/seg.c    |  2 +-
 mps/code/trace.c  | 16 ++++++++--------
 4 files changed, 21 insertions(+), 13 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index 59a44ee3780..f9ce6fb9396 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -637,10 +637,18 @@
 
 /* Experimental Scan Barrier threshold
  *
- * The number of unecessary scans performed, before raising the write
- * barrier to remember the refset summary.
  */
-#define TRACE_SCAN_BARRIER_THRESHOLD 3
+/* Number of bits needed to keep the seg scan count */
+#define SEG_SCANS_BITS 10
+/* The number of unecessary scans performed, before raising the write
+ * barrier to remember the refset summary. */
+#define SEG_SCANS_INIT 3
+/* The number of unecessary scans performed, before raising the write
+ * barrier to remember the refset summary, after a necessary scan */
+#define SEG_SCANS_AFTER_NEEDED_SCAN 3
+/* The number of unecessary scans performed, before raising the write
+ * barrier to remember the refset summary, after a barrier hit */
+#define SEG_SCANS_AFTER_HIT 1
 
 #endif /* config_h */
 
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index ba0be7aba58..39625a470f6 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -285,6 +285,7 @@ typedef struct SegStruct {      /* segment structure */
   TraceSet white : TraceLIMIT;  /* traces for which seg is white */
   TraceSet nailed : TraceLIMIT; /* traces for which seg has nailed objects */
   RankSet rankSet : RankLIMIT;  /* ranks of references in this seg */
+  unsigned scans : SEG_SCANS_BITS; /* use write barrier after this many scans */
 } SegStruct;
 
 
@@ -300,7 +301,6 @@ typedef struct GCSegStruct {    /* GC segment structure */
   RingStruct greyRing;          /* link in list of grey segs */
   RefSet summary;               /* summary of references out of seg */
   Buffer buffer;                /* non-NULL if seg is buffered */
-  unsigned unnecessaryScans;    /* consecutive unnecessary scans performed */
   Sig sig;                      /* <design/sig/> */
 } GCSegStruct;
 
diff --git a/mps/code/seg.c b/mps/code/seg.c
index e5923c170f7..99e3c48e47c 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -160,6 +160,7 @@ static Res SegInit(Seg seg, Pool pool, Addr base, Size size,
   seg->grey = TraceSetEMPTY;
   seg->pm = AccessSetEMPTY;
   seg->sm = AccessSetEMPTY;
+  seg->scans = SEG_SCANS_INIT;
   seg->depth = 0;
   seg->firstTract = NULL;
 
@@ -1082,7 +1083,6 @@ static Res gcSegInit(Seg seg, Pool pool, Addr base, Size size,
 
   gcseg->summary = RefSetEMPTY;
   gcseg->buffer = NULL;
-  gcseg->unnecessaryScans = 0;
   RingInit(&gcseg->greyRing);
   gcseg->sig = GCSegSig;
 
diff --git a/mps/code/trace.c b/mps/code/trace.c
index bbe09b2d2c6..2856d3339cb 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1105,7 +1105,6 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
   } else {      /* scan it */
     ScanStateStruct ssStruct;
     ScanState ss = &ssStruct;
-    Bool considerBarrier = FALSE;
     ScanStateInit(ss, ts, arena, rank, white);
 
     /* Expose the segment to make sure we can scan it. */
@@ -1138,16 +1137,14 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
     AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
     if (ZoneSetInter(ScanStateUnfixedSummary(ss), white) == ZoneSetEMPTY) {
       /* a scan was not necessary */
-      if (((GCSeg)seg)->unnecessaryScans < TRACE_SCAN_BARRIER_THRESHOLD) {
-        ((GCSeg)seg)->unnecessaryScans++;
-      } else {
-        considerBarrier = TRUE;
-      }
+      if (seg->scans > 0)
+        seg->scans--;
     } else {
-      ((GCSeg)seg)->unnecessaryScans = 0;
+      if (seg->scans < SEG_SCANS_AFTER_NEEDED_SCAN)
+        seg->scans = SEG_SCANS_AFTER_NEEDED_SCAN;
     }
     
-    if (considerBarrier) {
+    if (seg->scans == 0) {
       if(res != ResOK || !wasTotal) {
         /* scan was partial, so... */
         /* scanned summary should be ORed into segment summary. */
@@ -1217,6 +1214,9 @@ void TraceSegAccess(Arena arena, Seg seg, AccessSet mode)
 
   EVENT3(TraceAccess, arena, seg, mode);
 
+  if ((mode & SegSM(seg) & AccessWRITE) != 0)     /* write barrier? */
+    seg->scans = SEG_SCANS_AFTER_HIT;
+
   if((mode & SegSM(seg) & AccessREAD) != 0) {   /* read barrier? */
     Trace trace;
     TraceId ti;

From 8c833d105775c9879708e4d7968afb99b1273907 Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Fri, 11 Mar 2016 12:47:23 +0000
Subject: [PATCH 07/69] Branching master to branch/2016-03-11/shield-coalesce.

Copied from Perforce
 Change: 189856
 ServerID: perforce.ravenbrook.com

From 2d98fb21188a9333ea35d6a4e5230544bab3dddf Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Fri, 11 Mar 2016 15:07:48 +0000
Subject: [PATCH 08/69] Rename functions cache() and flush().

Copied from Perforce
 Change: 189868
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 18 ++++++++++++------
 1 file changed, 12 insertions(+), 6 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index 0dfc1945db6..326ffc18052 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -127,7 +127,7 @@ static void shieldSync(Arena arena, Seg seg)
 }
 
 
-static void flush(Arena arena, Size i)
+static void shieldFlushEntry(Arena arena, Size i)
 {
   Seg seg;
   AVERT(Arena, arena);
@@ -153,7 +153,7 @@ static void flush(Arena arena, Size i)
 /* If the segment is out of sync, either sync it, or ensure
  * depth > 0, and the arena is suspended.
  */
-static void cache(Arena arena, Seg seg)
+static void shieldCache(Arena arena, Seg seg)
 {
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
@@ -174,7 +174,7 @@ static void cache(Arena arena, Seg seg)
     AVER(SegDepth(seg) > 0);
     AVER(arena->shCacheLimit <= ShieldCacheSIZE);
     AVER(arena->shCacheI < arena->shCacheLimit);
-    flush(arena, arena->shCacheI);
+    shieldFlushEntry(arena, arena->shCacheI);
     arena->shCache[arena->shCacheI] = seg;
     ++arena->shCacheI;
     if (arena->shCacheI == ShieldCacheSIZE)
@@ -197,7 +197,7 @@ void (ShieldRaise) (Arena arena, Seg seg, AccessSet mode)
   SegSetSM(seg, SegSM(seg) | mode); /* inv.prot.shield preserved */
 
   /* ensure inv.unsynced.suspended & inv.unsynced.depth */
-  cache(arena, seg);
+  shieldCache(arena, seg);
   AVERT(Arena, arena);
   AVERT(Seg, seg);
 }
@@ -241,6 +241,12 @@ void (ShieldEnter)(Arena arena)
 /* .shield.flush: Flush empties the shield cache.
  * This needs to be called before segments are destroyed as there
  * may be references to them in the cache.
+ *
+ * The memory for the segment may become spare, and not released back to
+ * the operating system. Since we keep track of protection on segments
+ * and not grains we have no way of keeping track of the protection
+ * state of spare grains. We therefore flush the protection to get it
+ * back into the default state (unprotected).
  */
 void (ShieldFlush)(Arena arena)
 {
@@ -249,7 +255,7 @@ void (ShieldFlush)(Arena arena)
   for(i = 0; i < arena->shCacheLimit; ++i) {
     if (arena->shDepth == 0)
       break;
-    flush(arena, i);
+    shieldFlushEntry(arena, i);
   }
 }
 
@@ -333,7 +339,7 @@ void (ShieldCover)(Arena arena, Seg seg)
   --arena->shDepth;
 
   /* ensure inv.unsynced.depth */
-  cache(arena, seg);
+  shieldCache(arena, seg);
 }
 
 

From 3669ed07b88cec5988ea08bd03c4a578b6b90de5 Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Fri, 11 Mar 2016 17:05:01 +0000
Subject: [PATCH 09/69] Basic coalescing of protects on shield flush.

Copied from Perforce
 Change: 189871
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 102 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 100 insertions(+), 2 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index 326ffc18052..bd141bdb489 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -73,6 +73,7 @@
  */
 
 #include "mpm.h"
+#include "stdlib.h" /* For qsort, move */
 
 SRCID(shield, "$Id$");
 
@@ -150,6 +151,100 @@ static void shieldFlushEntry(Arena arena, Size i)
 }
 
 
+/* We sort NULLs to the end, and otherwise sort by base address */
+static int shieldCacheEntryCompare(const void *a, const void *b)
+{
+  Seg segA = *(SegStruct * const *)a, segB = *(SegStruct * const *)b;
+  Addr baseA, baseB;
+  if (segA != NULL)
+    AVERT(Seg, segA);
+  if (segB != NULL)
+    AVERT(Seg, segB);
+
+  if (segA == NULL) {
+    if (segB == NULL) return 0;
+    else return 1;
+  }
+  if (segB == NULL) {
+     AVER(segA != NULL);
+     return -1;
+  }
+  baseA = SegBase(segA);
+  baseB = SegBase(segB);
+  if (baseA < baseB)
+    return -1;
+  if (baseA > baseB)
+    return 1;
+  AVER(baseA == baseB);
+  return 0;
+}
+
+
+/* shieldFlushEntries -- flush cache coalescing protects
+ *
+ * base, limit and mode represent outstanding protection to be done.
+ */
+
+static void shieldFlushEntries(Arena arena)
+{
+  Addr base = 0, limit = 0;
+  AccessSet mode = 0;
+  Seg seg;
+  Size i;
+  qsort(arena->shCache, arena->shCacheLimit, sizeof(arena->shCache[0]),
+        shieldCacheEntryCompare);
+  seg = arena->shCache[0];
+  if (seg) {
+    AVERT(Seg, seg);
+    arena->shCache[0] = NULL;
+
+    AVER(arena->shDepth > 0);
+    AVER(SegDepth(seg) > 0);
+    --arena->shDepth;
+    SegSetDepth(seg, SegDepth(seg) - 1);
+
+    if (SegSM(seg) != SegPM(seg)) {
+      SegSetPM(seg, SegSM(seg));
+      base = SegBase(seg);
+      limit = SegLimit(seg);
+      mode = SegSM(seg);
+    }
+  }
+  for (i=1; i < arena->shCacheLimit; ++i) {
+    if (arena->shDepth == 0)
+      break;
+    seg = arena->shCache[i];
+    /* All the NULLs are sorted to the end */
+    if (seg == NULL)
+      break;
+    AVERT(Seg, seg);
+    arena->shCache[i] = NULL;
+
+    AVER(arena->shDepth > 0);
+    AVER(SegDepth(seg) > 0);
+    --arena->shDepth;
+    SegSetDepth(seg, SegDepth(seg) - 1);
+
+    if (SegSM(seg) != SegPM(seg)) {
+      SegSetPM(seg, SegSM(seg));
+      if (SegBase(seg) != limit || mode != SegSM(seg)) {
+        if (limit != 0) {
+          ProtSet(base, limit, mode);
+        }
+        base = SegBase(seg);
+        limit = SegLimit(seg);
+        mode = SegSM(seg);
+      } else {
+        limit = SegLimit(seg);
+      }
+    }
+  }
+  if (limit != 0) {
+    ProtSet(base, limit, mode);
+  }
+}
+
+
 /* If the segment is out of sync, either sync it, or ensure
  * depth > 0, and the arena is suspended.
  */
@@ -229,7 +324,7 @@ void (ShieldEnter)(Arena arena)
   AVER(!arena->suspended);
   AVER(arena->shCacheLimit <= ShieldCacheSIZE);
   AVER(arena->shCacheI < arena->shCacheLimit);
-  for(i = 0; i < arena->shCacheLimit; i++)
+  for (i = 0; i < arena->shCacheLimit; i++)
     AVER(arena->shCache[i] == NULL);
 
   arena->shCacheI = (Size)0;
@@ -252,7 +347,10 @@ void (ShieldFlush)(Arena arena)
 {
   Size i;
 
-  for(i = 0; i < arena->shCacheLimit; ++i) {
+  if(1)
+    shieldFlushEntries(arena);
+
+  for (i = 0; i < arena->shCacheLimit; ++i) {
     if (arena->shDepth == 0)
       break;
     shieldFlushEntry(arena, i);

From dbbea04f7fb656567af3d79131494ded5a9036f8 Mon Sep 17 00:00:00 2001
From: David Lovemore <dl@ravenbrook.com>
Date: Fri, 11 Mar 2016 17:05:45 +0000
Subject: [PATCH 10/69] Bigger shield cache, to make coalescing more useful.

Copied from Perforce
 Change: 189872
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index 11d5a943a04..dcc5a1731e9 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -475,8 +475,8 @@
 
 /* Shield Configuration -- see <code/shield.c> */
 
-#define ShieldCacheSIZE ((size_t)16)
-#define ShieldDepthWIDTH (4)
+#define ShieldCacheSIZE ((size_t)1024)
+#define ShieldDepthWIDTH (10)
 
 
 /* VM Configuration -- see <code/vm*.c> */

From 40dadc912b523a54b9eb08675186a45475990186 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 13 Mar 2016 11:10:00 +0000
Subject: [PATCH 11/69] Branching master to
 branch/2016-03-13/defer-write-barrier.

Copied from Perforce
 Change: 189939
 ServerID: perforce.ravenbrook.com

From 17b529001bd50465b8cbf244192678f6837b7254 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 13 Mar 2016 12:16:01 +0000
Subject: [PATCH 12/69] Fixing incomplete merge that missed out disabling the
 write barrier, but corrupted the segment summaries.

Copied from Perforce
 Change: 189954
 ServerID: perforce.ravenbrook.com
---
 mps/code/trace.c | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/mps/code/trace.c b/mps/code/trace.c
index acbf4ba7d20..f8a9494067f 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1153,6 +1153,8 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
         /* scanned summary should replace the segment summary. */
         SegSetSummary(seg, ScanStateSummary(ss));
       }
+    } else {
+      SegSetSummary(seg, RefSetUNIV);
     }
 
     ScanStateFinish(ss);

From 47dbed0eee381d90f92c2f98459b14ab04e039e5 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 13 Mar 2016 13:26:24 +0000
Subject: [PATCH 13/69] Tidying up naming of write barrier deferral.

Copied from Perforce
 Change: 189960
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h | 28 ++++++++++++++++++++--------
 mps/code/mpmst.h  |  2 +-
 mps/code/seg.c    |  2 +-
 mps/code/trace.c  | 42 ++++++++++++++++++++++++------------------
 4 files changed, 46 insertions(+), 28 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index 50cb0aece82..5204171795b 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -659,20 +659,32 @@
     { 36 * 1024, 0.45 }  /* second gen, after which dynamic */ \
   }
 
-/* Experimental Scan Barrier threshold
+/* Write barrier deferral
  *
+ * Defer using the write barrier for the remembered set until a number
+ * of unnecessary scans have been performed on a segment.  Avoids
+ * memory protection costs when scanning might be cheaper.  See job003975.
+ *
+ * TODO: These settings were determined by trial and error, but should
+ * be based on measurement of the protection overhead on each
+ * platform.  We know it's extremely different between OS X and
+ * Windows, for example.
+ *
+ * TODO: Consider basing the count on the amount of time that has
+ * passed in the mutator rather than the number of scans.
  */
-/* Number of bits needed to keep the seg scan count */
-#define SEG_SCANS_BITS 10
+
+/* Number of bits needed to keep the write barrier deferral count */
+#define WB_DEFER_BITS 3
 /* The number of unecessary scans performed, before raising the write
- * barrier to remember the refset summary. */
-#define SEG_SCANS_INIT 3
+   barrier to maintian the remembered set. */
+#define WB_DEFER_INIT 3
 /* The number of unecessary scans performed, before raising the write
- * barrier to remember the refset summary, after a necessary scan */
-#define SEG_SCANS_AFTER_NEEDED_SCAN 3
+   barrier to remember the refset summary, after a necessary scan */
+#define WB_DEFER_DELAY WB_DEFER_INIT
 /* The number of unecessary scans performed, before raising the write
  * barrier to remember the refset summary, after a barrier hit */
-#define SEG_SCANS_AFTER_HIT 1
+#define WB_DEFER_AFTER_HIT 1
 
 #endif /* config_h */
 
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 5636bf22b28..48f80eb2255 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -281,7 +281,7 @@ typedef struct SegStruct {      /* segment structure */
   TraceSet white : TraceLIMIT;  /* traces for which seg is white */
   TraceSet nailed : TraceLIMIT; /* traces for which seg has nailed objects */
   RankSet rankSet : RankLIMIT;  /* ranks of references in this seg */
-  unsigned scans : SEG_SCANS_BITS; /* use write barrier after this many scans */
+  Count defer : WB_DEFER_BITS;  /* defer write barrier for this many scans */
 } SegStruct;
 
 
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 1e693d8a48d..31ef5bd8b64 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -160,7 +160,7 @@ static Res SegInit(Seg seg, Pool pool, Addr base, Size size,
   seg->grey = TraceSetEMPTY;
   seg->pm = AccessSetEMPTY;
   seg->sm = AccessSetEMPTY;
-  seg->scans = SEG_SCANS_INIT;
+  seg->defer = WB_DEFER_INIT;
   seg->depth = 0;
   seg->firstTract = NULL;
 
diff --git a/mps/code/trace.c b/mps/code/trace.c
index f8a9494067f..bd3175fc5aa 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1089,6 +1089,7 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
   Bool wasTotal;
   ZoneSet white;
   Res res;
+  RefSet summary;
 
   /* The reason for scanning a segment is that it's grey. */
   AVER(TraceSetInter(ts, SegGrey(seg)) != TraceSetEMPTY);
@@ -1134,28 +1135,33 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
      * scan, consistent with the recorded SegSummary?
      */
     AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
+
+    /* Remembered set and write barrier */
+    /* Was the scan necessary?  Did the segment refer to the white set */
     if (ZoneSetInter(ScanStateUnfixedSummary(ss), white) == ZoneSetEMPTY) {
-      /* a scan was not necessary */
-      if (seg->scans > 0)
-        seg->scans--;
+      if (seg->defer > 0)
+        --seg->defer;
     } else {
-      if (seg->scans < SEG_SCANS_AFTER_NEEDED_SCAN)
-        seg->scans = SEG_SCANS_AFTER_NEEDED_SCAN;
+      if (seg->defer < WB_DEFER_DELAY)
+        seg->defer = WB_DEFER_DELAY;
     }
-    
-    if (seg->scans == 0) {
-      if(res != ResOK || !wasTotal) {
-        /* scan was partial, so... */
-        /* scanned summary should be ORed into segment summary. */
-        SegSetSummary(seg, RefSetUnion(SegSummary(seg), ScanStateSummary(ss)));
-      } else {
-        /* all objects on segment have been scanned, so... */
-        /* scanned summary should replace the segment summary. */
-        SegSetSummary(seg, ScanStateSummary(ss));
-      }
+
+    /* Only apply the write barrier if it is not deferred. */
+    /* TODO: This discards information we collected during
+       scanning. Consider keeping the summary but changing the
+       invariant on shielding instead. */
+    if (seg->defer == 0) {
+      /* If we scanned every reference in the segment then we have a
+         complete summary we can set. Otherwise, we just have
+         information about more zones that the segment refers to. */
+      if (res == ResOK && wasTotal)
+        summary = ScanStateSummary(ss);
+      else
+        summary = RefSetUnion(SegSummary(seg), ScanStateSummary(ss));
     } else {
-      SegSetSummary(seg, RefSetUNIV);
+      summary = RefSetUNIV;
     }
+    SegSetSummary(seg, summary);
 
     ScanStateFinish(ss);
   }
@@ -1215,7 +1221,7 @@ void TraceSegAccess(Arena arena, Seg seg, AccessSet mode)
   EVENT3(TraceAccess, arena, seg, mode);
 
   if ((mode & SegSM(seg) & AccessWRITE) != 0)     /* write barrier? */
-    seg->scans = SEG_SCANS_AFTER_HIT;
+    seg->defer = WB_DEFER_AFTER_HIT;
 
   if((mode & SegSM(seg) & AccessREAD) != 0) {   /* read barrier? */
     Trace trace;

From ca73a994c09247a18b611149300bbfc48059f5cd Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 13 Mar 2016 14:09:38 +0000
Subject: [PATCH 14/69] Simplifying segsetsummary by not requiring it to
 calculate the previous shield mode.

Copied from Perforce
 Change: 189963
 ServerID: perforce.ravenbrook.com
---
 mps/code/seg.c    | 29 ++++++++++++-----------------
 mps/code/shield.c |  2 --
 2 files changed, 12 insertions(+), 19 deletions(-)

diff --git a/mps/code/seg.c b/mps/code/seg.c
index 31ef5bd8b64..12e7fc10737 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -740,6 +740,7 @@ Bool SegCheck(Seg seg)
     /* write shielded. */
     /* CHECKL(seg->_summary == RefSetUNIV || (seg->_sm & AccessWRITE)); */
     /* @@@@ What can be checked about the read barrier? */
+    /* FIXME: Need gcSegCheck? CHECKL(seg->defer == 0 || seg->summary == RefSetUNIV); */
   }
   return TRUE;
 }
@@ -1345,7 +1346,6 @@ static void gcSegSetRankSet(Seg seg, RankSet rankSet)
 static void gcSegSetSummary(Seg seg, RefSet summary)
 {
   GCSeg gcseg;
-  RefSet oldSummary;
   Arena arena;
 
   AVERT_CRITICAL(Seg, seg);                 /* .seg.method.check */
@@ -1354,19 +1354,16 @@ static void gcSegSetSummary(Seg seg, RefSet summary)
   AVER_CRITICAL(&gcseg->segStruct == seg);
 
   arena = PoolArena(SegPool(seg));
-  oldSummary = gcseg->summary;
   gcseg->summary = summary;
 
   AVER(seg->rankSet != RankSetEMPTY);
 
   /* Note: !RefSetSuper is a test for a strict subset */
-  if (!RefSetSuper(summary, RefSetUNIV)) {
-    if (RefSetSuper(oldSummary, RefSetUNIV))
-      ShieldRaise(arena, seg, AccessWRITE);
-  } else {
-    if (!RefSetSuper(oldSummary, RefSetUNIV))
-      ShieldLower(arena, seg, AccessWRITE);
-  }
+  /* FIXME: Duplicate code with gcSegSetRankSummary. */
+  if (!RefSetSuper(summary, RefSetUNIV))
+    ShieldRaise(arena, seg, AccessWRITE);
+  else
+    ShieldLower(arena, seg, AccessWRITE);
 }
 
 
@@ -1375,7 +1372,6 @@ static void gcSegSetSummary(Seg seg, RefSet summary)
 static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
 {
   GCSeg gcseg;
-  Bool wasShielded, willbeShielded;
   Arena arena;
 
   AVERT_CRITICAL(Seg, seg);                    /* .seg.method.check */
@@ -1391,16 +1387,15 @@ static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
 
   arena = PoolArena(SegPool(seg));
 
-  wasShielded = (seg->rankSet != RankSetEMPTY && gcseg->summary != RefSetUNIV);
-  willbeShielded = (rankSet != RankSetEMPTY && summary != RefSetUNIV);
-
   seg->rankSet = BS_BITFIELD(Rank, rankSet);
   gcseg->summary = summary;
 
-  if (willbeShielded && !wasShielded) {
-    ShieldRaise(arena, seg, AccessWRITE);
-  } else if (wasShielded && !willbeShielded) {
-    ShieldLower(arena, seg, AccessWRITE);
+  if (rankSet != RankSetEMPTY) {
+    /* FIXME: Duplicate code with gcSegSetSummary. */
+    if (!RefSetSuper(summary, RefSetUNIV))
+      ShieldRaise(arena, seg, AccessWRITE);
+    else
+      ShieldLower(arena, seg, AccessWRITE);
   }
 }
 
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 0dfc1945db6..56c00d76be9 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -193,7 +193,6 @@ void (ShieldRaise) (Arena arena, Seg seg, AccessSet mode)
   /* segs in the cache. */
 
   AVERT(AccessSet, mode);
-  AVER((SegSM(seg) & mode) == AccessSetEMPTY);
   SegSetSM(seg, SegSM(seg) | mode); /* inv.prot.shield preserved */
 
   /* ensure inv.unsynced.suspended & inv.unsynced.depth */
@@ -207,7 +206,6 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 {
   /* Don't check seg or arena, see .seg.broken */
   AVERT(AccessSet, mode);
-  AVER((SegSM(seg) & mode) == mode);
   /* synced(seg) is not changed by the following
    * preserving inv.unsynced.suspended
    * Also inv.prot.shield preserved

From e89429df8b98031a22da892f3046bef442b8543a Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 13 Mar 2016 14:23:41 +0000
Subject: [PATCH 15/69] Can't use count as a bitfield.

Copied from Perforce
 Change: 189965
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpmst.h | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 48f80eb2255..f998da4da21 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -281,7 +281,7 @@ typedef struct SegStruct {      /* segment structure */
   TraceSet white : TraceLIMIT;  /* traces for which seg is white */
   TraceSet nailed : TraceLIMIT; /* traces for which seg has nailed objects */
   RankSet rankSet : RankLIMIT;  /* ranks of references in this seg */
-  Count defer : WB_DEFER_BITS;  /* defer write barrier for this many scans */
+  unsigned defer : WB_DEFER_BITS; /* defer write barrier for this many scans */
 } SegStruct;
 
 

From 662a1b1b9bb8ac726407881af6325a772cdaaaa7 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 17 Mar 2016 13:37:40 +0000
Subject: [PATCH 16/69] Allocate the shield cache. also improve commentary
 quite a bit.

Copied from Perforce
 Change: 190147
 ServerID: perforce.ravenbrook.com
---
 mps/code/global.c |  22 ++++++--
 mps/code/mpmst.h  |   3 +-
 mps/code/shield.c | 138 +++++++++++++++++++++++++++++-----------------
 3 files changed, 107 insertions(+), 56 deletions(-)

diff --git a/mps/code/global.c b/mps/code/global.c
index 354adb54a9a..aa9847451a0 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -156,8 +156,9 @@ Bool GlobalsCheck(Globals arenaGlobals)
   CHECKD_NOSIG(Ring, &arena->deadRing);
 
   CHECKL(BoolCheck(arena->insideShield));
-  CHECKL(arena->shCacheLimit <= ShieldCacheSIZE);
-  CHECKL(arena->shCacheI < arena->shCacheLimit);
+  CHECKL(arena->shCache == NULL || arena->shCacheLength > 0);
+  CHECKL(arena->shCacheLimit <= arena->shCacheLength);
+  CHECKL(arena->shCacheI <= arena->shCacheLimit);
   CHECKL(BoolCheck(arena->suspended));
 
   depth = 0;
@@ -293,12 +294,12 @@ Res GlobalsInit(Globals arenaGlobals)
   arena->tracedTime = 0.0;
   arena->lastWorldCollect = ClockNow();
   arena->insideShield = FALSE;          /* <code/shield.c> */
+  arena->shCache = NULL;
+  arena->shCacheLength = 0;
   arena->shCacheI = (Size)0;
-  arena->shCacheLimit = (Size)1;
+  arena->shCacheLimit = (Size)0;
   arena->shDepth = (Size)0;
   arena->suspended = FALSE;
-  for(i = 0; i < ShieldCacheSIZE; i++)
-    arena->shCache[i] = NULL;
 
   for (ti = 0; ti < TraceLIMIT; ++ti) {
     /* <design/arena/#trace.invalid> */
@@ -435,6 +436,16 @@ void GlobalsPrepareToDestroy(Globals arenaGlobals)
   ArenaPark(arenaGlobals);
 
   arena = GlobalsArena(arenaGlobals);
+
+  /* Delete the shield cache, if it exists. */
+  if (arena->shCacheLength != 0) {
+    AVER(arena->shCache != NULL);
+    ControlFree(arena, arena->shCache,
+                arena->shCacheLength * sizeof arena->shCache[0]);
+    arena->shCache = NULL;
+    arena->shCacheLength = 0;
+  }
+
   arenaDenounce(arena);
 
   defaultChain = arenaGlobals->defaultChain;
@@ -1019,6 +1030,7 @@ Res GlobalsDescribe(Globals arenaGlobals, mps_lib_FILE *stream, Count depth)
                "suspended $S\n", WriteFYesNo(arena->suspended),
                "shDepth $U\n", (WriteFU)arena->shDepth,
                "shCacheI $U\n", (WriteFU)arena->shCacheI,
+               "shCacheLength $U\n", (WriteFU)arena->shCacheLength,
                /* @@@@ should SegDescribe the cached segs? */
                NULL);
   if (res != ResOK)
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 8b76dec162a..dd613f816af 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -760,7 +760,8 @@ typedef struct mps_arena_s {
  
   /* shield fields (<code/shield.c>) */
   Bool insideShield;             /* TRUE if and only if inside shield */
-  Seg shCache[ShieldCacheSIZE];  /* Cache of unsynced segs */
+  Seg *shCache;                  /* Cache of unsynced segs */
+  Count shCacheLength;
   Size shCacheI;                 /* index into cache */
   Size shCacheLimit;             /* High water mark for cache usage */
   Size shDepth;                  /* sum of depths of all segs */
diff --git a/mps/code/shield.c b/mps/code/shield.c
index bd141bdb489..0ad3c0fb979 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -135,8 +135,6 @@ static void shieldFlushEntry(Arena arena, Size i)
   AVER(i < arena->shCacheLimit);
 
   seg = arena->shCache[i];
-  if (seg == NULL)
-    return;
   AVERT(Seg, seg);
 
   AVER(arena->shDepth > 0);
@@ -147,28 +145,18 @@ static void shieldFlushEntry(Arena arena, Size i)
   if (SegDepth(seg) == 0)
     shieldSync(arena, seg);
 
-  arena->shCache[i] = NULL;
+  arena->shCache[i] = NULL; /* just to make sure it gets overwritten */
 }
 
 
-/* We sort NULLs to the end, and otherwise sort by base address */
 static int shieldCacheEntryCompare(const void *a, const void *b)
 {
   Seg segA = *(SegStruct * const *)a, segB = *(SegStruct * const *)b;
   Addr baseA, baseB;
-  if (segA != NULL)
-    AVERT(Seg, segA);
-  if (segB != NULL)
-    AVERT(Seg, segB);
+  
+  AVERT(Seg, segA); /* FIXME: Might be critical? */
+  AVERT(Seg, segB);
 
-  if (segA == NULL) {
-    if (segB == NULL) return 0;
-    else return 1;
-  }
-  if (segB == NULL) {
-     AVER(segA != NULL);
-     return -1;
-  }
   baseA = SegBase(segA);
   baseB = SegBase(segB);
   if (baseA < baseB)
@@ -180,6 +168,14 @@ static int shieldCacheEntryCompare(const void *a, const void *b)
 }
 
 
+static void shieldCacheReset(Arena arena)
+{
+  AVER(arena->shDepth == 0);
+  arena->shCacheI = 0;
+  arena->shCacheLimit = 0;
+}
+
+
 /* shieldFlushEntries -- flush cache coalescing protects
  *
  * base, limit and mode represent outstanding protection to be done.
@@ -191,12 +187,21 @@ static void shieldFlushEntries(Arena arena)
   AccessSet mode = 0;
   Seg seg;
   Size i;
-  qsort(arena->shCache, arena->shCacheLimit, sizeof(arena->shCache[0]),
+  if (arena->shDepth == 0)
+    return;
+  AVER(arena->shCache != NULL);
+  AVER(arena->shCacheLength > 0);
+
+  /* FIXME: This needs to go through the plinth. */
+  /* FIXME: We probably can't use libc's qsort because we can't bound
+     its use of stack space. */
+  qsort(arena->shCache, arena->shCacheLimit, sizeof arena->shCache[0],
         shieldCacheEntryCompare);
-  seg = arena->shCache[0];
+
+  seg = arena->shCache[0]; /* lowest address segment */
   if (seg) {
     AVERT(Seg, seg);
-    arena->shCache[0] = NULL;
+    arena->shCache[0] = NULL; /* just to make sure it isn't reused */
 
     AVER(arena->shDepth > 0);
     AVER(SegDepth(seg) > 0);
@@ -214,11 +219,8 @@ static void shieldFlushEntries(Arena arena)
     if (arena->shDepth == 0)
       break;
     seg = arena->shCache[i];
-    /* All the NULLs are sorted to the end */
-    if (seg == NULL)
-      break;
     AVERT(Seg, seg);
-    arena->shCache[i] = NULL;
+    arena->shCache[i] = NULL; /* just to make sure it isn't reused */
 
     AVER(arena->shDepth > 0);
     AVER(SegDepth(seg) > 0);
@@ -242,6 +244,7 @@ static void shieldFlushEntries(Arena arena)
   if (limit != 0) {
     ProtSet(base, limit, mode);
   }
+  shieldCacheReset(arena);
 }
 
 
@@ -254,29 +257,68 @@ static void shieldCache(Arena arena, Seg seg)
   AVERT_CRITICAL(Arena, arena);
   AVERT_CRITICAL(Seg, seg);
 
-  if (SegSM(seg)
-    == SegPM(seg)) return;
-  if (SegDepth(seg) > 0) {
+  if (SegSM(seg) == SegPM(seg))
+    return;
+  if (SegDepth(seg) > 0) { /* already in the cache or exposed? */
+    /* This can occur if the mutator isn't suspended, we expose a
+       segment, then raise the shield on it.  In this case, the
+       mutator isn't allowed to see the segment, but we don't need to
+       cache it until its covered. */
     ShieldSuspend(arena);
     return;
   }
-  if (ShieldCacheSIZE == 0 || !arena->suspended)
-    shieldSync(arena, seg);
-  else {
-    SegSetDepth(seg, SegDepth(seg) + 1);
-    ++arena->shDepth;
-    AVER(arena->shDepth > 0);
-    AVER(SegDepth(seg) > 0);
-    AVER(arena->shCacheLimit <= ShieldCacheSIZE);
-    AVER(arena->shCacheI < arena->shCacheLimit);
-    shieldFlushEntry(arena, arena->shCacheI);
-    arena->shCache[arena->shCacheI] = seg;
-    ++arena->shCacheI;
-    if (arena->shCacheI == ShieldCacheSIZE)
-      arena->shCacheI = 0;
-    if (arena->shCacheI == arena->shCacheLimit)
-      ++arena->shCacheLimit;
+
+  /* Allocate shield cache if necessary. */
+  if (arena->shCacheLength == 0) {
+    void *p;
+    Res res;
+    
+    AVER(arena->shCache == NULL);
+
+    res = ControlAlloc(&p, arena, ShieldCacheSIZE * sizeof arena->shCache[0], FALSE);
+    if (res != ResOK) {
+      AVER(res == ResMEMORY);
+    } else {
+      arena->shCache = p;
+      arena->shCacheLength = ShieldCacheSIZE;
+    }
   }
+
+  /* Cache unavailable, so synchronize now.  Or if the mutator is not
+     yet suspended and the code raises the shield on a covered
+     segment, protect it now, because that's probably better than
+     suspending the mutator. */
+  if (arena->shCacheLength == 0 || !arena->suspended) {
+    shieldSync(arena, seg);
+    return;
+  }
+
+  SegSetDepth(seg, SegDepth(seg) + 1);
+  AVER(SegDepth(seg) > 0); /* overflow */
+  ++arena->shDepth;
+  AVER(arena->shDepth > 0); /* overflow */
+
+  AVER(arena->shCacheLimit <= arena->shCacheLength);
+  AVER(arena->shCacheI <= arena->shCacheLimit);
+
+  if (arena->shCacheI >= arena->shCacheLength)
+    arena->shCacheI = 0;
+  AVER(arena->shCacheI < arena->shCacheLength);
+
+  AVER(arena->shCacheLength > 0);
+
+  /* If the limit is less than the length, then the cache array has
+     yet to be filled, and shCacheI is an uninitialized entry.
+     Otherwise it's the tail end from last time around, and needs to
+     be flushed. */
+  if (arena->shCacheLimit == arena->shCacheLength)
+    shieldFlushEntry(arena, arena->shCacheI);
+
+  arena->shCache[arena->shCacheI] = seg;
+  ++arena->shCacheI;
+
+  if (arena->shCacheI >= arena->shCacheLimit)
+    arena->shCacheLimit = arena->shCacheI;
 }
 
 
@@ -316,19 +358,15 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 
 void (ShieldEnter)(Arena arena)
 {
-  Size i;
-
   AVERT(Arena, arena);
   AVER(!arena->insideShield);
   AVER(arena->shDepth == 0);
   AVER(!arena->suspended);
-  AVER(arena->shCacheLimit <= ShieldCacheSIZE);
-  AVER(arena->shCacheI < arena->shCacheLimit);
-  for (i = 0; i < arena->shCacheLimit; i++)
-    AVER(arena->shCache[i] == NULL);
+  AVER(arena->shCacheLimit <= arena->shCacheLength);
+  AVER(arena->shCacheI <= arena->shCacheLimit);
+
+  shieldCacheReset(arena);
 
-  arena->shCacheI = (Size)0;
-  arena->shCacheLimit = (Size)1;
   arena->insideShield = TRUE;
 }
 

From 8df13d0bffe08c9ce41c8acc98304f4164a85444 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 17 Mar 2016 16:55:14 +0000
Subject: [PATCH 17/69] Shield cache that grows.  improving commentary.

Copied from Perforce
 Change: 190160
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h |   4 +-
 mps/code/shield.c | 107 +++++++++++++++++++++++++++++++++-------------
 mps/code/trace.c  |   1 +
 3 files changed, 81 insertions(+), 31 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index 7d5e849e04a..530bf90cb6e 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -483,8 +483,8 @@
 
 /* Shield Configuration -- see <code/shield.c> */
 
-#define ShieldCacheSIZE ((size_t)1024)
-#define ShieldDepthWIDTH (10)
+#define ShieldCacheSIZE  512
+#define ShieldDepthWIDTH 10
 
 
 /* VM Configuration -- see <code/vm*.c> */
diff --git a/mps/code/shield.c b/mps/code/shield.c
index cb3ff034ac9..3c2e29d8f08 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -78,6 +78,43 @@
 SRCID(shield, "$Id$");
 
 
+/* shieldSegIsSynced -- is a segment synced?
+ *
+ * See .def.synced.
+ */
+
+static Bool shieldSegIsSynced(Seg seg)
+{
+  AVERT_CRITICAL(Seg, seg);
+  return SegSM(seg) == SegPM(seg);
+}
+
+
+/* shieldSync -- synchronize a segment's protection */
+
+static void shieldSync(Arena arena, Seg seg)
+{
+  AVERT(Arena, arena);
+  AVERT(Seg, seg);
+
+  if (!shieldSegIsSynced(seg)) {
+    ProtSet(SegBase(seg), SegLimit(seg), SegSM(seg));
+    SegSetPM(seg, SegSM(seg));
+    /* See .inv.prot.shield. */
+  }
+}
+
+
+/* ShieldSuspend -- suspend the mutator
+ *
+ * From outside impl.c.shield, this is used when we really need to
+ * lock everything against the mutator -- for example, during flip
+ * when we must scan all thread registers at once.
+ *
+ * It is called from inside impl.c.shield when any segment is not
+ * synced -- see .inv.unsynced.suspended.
+ */
+
 void (ShieldSuspend)(Arena arena)
 {
   AVERT(Arena, arena);
@@ -90,6 +127,12 @@ void (ShieldSuspend)(Arena arena)
 }
 
 
+/* ShieldResume -- declare mutator could be resumed
+ *
+ * In practice, we don't resume the mutator until ShieldLeave, but
+ * this marks the earliest point at which we could resume.
+ */
+
 void (ShieldResume)(Arena arena)
 {
   AVERT(Arena, arena);
@@ -115,19 +158,6 @@ static void protLower(Arena arena, Seg seg, AccessSet mode)
 }
 
 
-static void shieldSync(Arena arena, Seg seg)
-{
-  AVERT(Arena, arena);
-  AVERT(Seg, seg);
-
-  if (SegPM(seg) != SegSM(seg)) {
-    ProtSet(SegBase(seg), SegLimit(seg), SegSM(seg));
-    SegSetPM(seg, SegSM(seg));
-    /* inv.prot.shield */
-  }
-}
-
-
 static void shieldFlushEntry(Arena arena, Size i)
 {
   Seg seg;
@@ -208,7 +238,7 @@ static void shieldFlushEntries(Arena arena)
     --arena->shDepth;
     SegSetDepth(seg, SegDepth(seg) - 1);
 
-    if (SegSM(seg) != SegPM(seg)) {
+    if (!shieldSegIsSynced(seg)) {
       SegSetPM(seg, SegSM(seg));
       base = SegBase(seg);
       limit = SegLimit(seg);
@@ -227,7 +257,7 @@ static void shieldFlushEntries(Arena arena)
     --arena->shDepth;
     SegSetDepth(seg, SegDepth(seg) - 1);
 
-    if (SegSM(seg) != SegPM(seg)) {
+    if (!shieldSegIsSynced(seg)) {
       SegSetPM(seg, SegSM(seg));
       if (SegBase(seg) != limit || mode != SegSM(seg)) {
         if (limit != 0) {
@@ -248,17 +278,21 @@ static void shieldFlushEntries(Arena arena)
 }
 
 
-/* If the segment is out of sync, either sync it, or ensure
- * depth > 0, and the arena is suspended.
+/* shieldCache -- consider adding a segment to the cache
+ *
+ * If the segment is out of sync, either sync it, or ensure depth > 0,
+ * and the arena is suspended.
  */
+
 static void shieldCache(Arena arena, Seg seg)
 {
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
   AVERT_CRITICAL(Seg, seg);
 
-  if (SegSM(seg) == SegPM(seg))
+  if (shieldSegIsSynced(seg))
     return;
+  
   if (SegDepth(seg) > 0) { /* already in the cache or exposed? */
     /* This can occur if the mutator isn't suspended, we expose a
        segment, then raise the shield on it.  In this case, the
@@ -269,18 +303,33 @@ static void shieldCache(Arena arena, Seg seg)
   }
 
   /* Allocate shield cache if necessary. */
-  if (arena->shCacheLength == 0) {
+  /* FIXME: This will try to extend the cache on every attempt, even
+     if it failed last time. That might be slow. */
+  if (arena->shCacheI >= arena->shCacheLength) {
     void *p;
     Res res;
-    
-    AVER(arena->shCache == NULL);
+    Count length;
 
-    res = ControlAlloc(&p, arena, ShieldCacheSIZE * sizeof arena->shCache[0]);
+    AVER(arena->shCacheI == arena->shCacheLength);
+
+    if (arena->shCacheLength == 0)
+      length = ShieldCacheSIZE;
+    else
+      length = arena->shCacheLength * 2;
+    
+    res = ControlAlloc(&p, arena, length * sizeof arena->shCache[0]);
     if (res != ResOK) {
       AVER(res == ResMEMORY);
+      /* Carry on with the existing cache. */
     } else {
+      if (arena->shCacheLength > 0) {
+        Size oldSize = arena->shCacheLength * sizeof arena->shCache[0];
+        AVER(arena->shCache != NULL);
+        mps_lib_memcpy(p, arena->shCache, oldSize);
+        ControlFree(arena, arena->shCache, oldSize);
+      }
       arena->shCache = p;
-      arena->shCacheLength = ShieldCacheSIZE;
+      arena->shCacheLength = length;
     }
   }
 
@@ -294,18 +343,18 @@ static void shieldCache(Arena arena, Seg seg)
   }
 
   SegSetDepth(seg, SegDepth(seg) + 1);
-  AVER(SegDepth(seg) > 0); /* overflow */
+  AVER_CRITICAL(SegDepth(seg) > 0); /* overflow */
   ++arena->shDepth;
-  AVER(arena->shDepth > 0); /* overflow */
+  AVER_CRITICAL(arena->shDepth > 0); /* overflow */
 
-  AVER(arena->shCacheLimit <= arena->shCacheLength);
-  AVER(arena->shCacheI <= arena->shCacheLimit);
+  AVER_CRITICAL(arena->shCacheLimit <= arena->shCacheLength);
+  AVER_CRITICAL(arena->shCacheI <= arena->shCacheLimit);
 
   if (arena->shCacheI >= arena->shCacheLength)
     arena->shCacheI = 0;
-  AVER(arena->shCacheI < arena->shCacheLength);
+  AVER_CRITICAL(arena->shCacheI < arena->shCacheLength);
 
-  AVER(arena->shCacheLength > 0);
+  AVER_CRITICAL(arena->shCacheLength > 0);
 
   /* If the limit is less than the length, then the cache array has
      yet to be filled, and shCacheI is an uninitialized entry.
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 6d9cb0f0f98..3c23e552990 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -737,6 +737,7 @@ Res TraceCreate(Trace *traceReturn, Arena arena, int why)
   /* buffers under our feet. */
   /* @@@@ This is a short-term fix for request.dylan.160098_. */
   /* .. _request.dylan.160098: https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/dylan/160098 */
+  /* FIXME: Where is the corresponding ShieldResume? */
   ShieldSuspend(arena);
 
   STATISTIC_STAT ({

From 4d889230f96e605d2b903fc14a5dcd839f2ef499 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 17 Mar 2016 18:22:08 +0000
Subject: [PATCH 18/69] Replacing qsort with an iterative implementation.

Copied from Perforce
 Change: 190166
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 51 ++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 44 insertions(+), 7 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index 3c2e29d8f08..d889ae80240 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -179,9 +179,8 @@ static void shieldFlushEntry(Arena arena, Size i)
 }
 
 
-static int shieldCacheEntryCompare(const void *a, const void *b)
+static int shieldCacheEntryCompare(Seg segA, Seg segB)
 {
-  Seg segA = *(SegStruct * const *)a, segB = *(SegStruct * const *)b;
   Addr baseA, baseB;
   
   AVERT(Seg, segA); /* FIXME: Might be critical? */
@@ -198,6 +197,48 @@ static int shieldCacheEntryCompare(const void *a, const void *b)
 }
 
 
+static void quicksort_iterative(Seg array[], Count len)
+{
+  static Index seed = 0x6A9D03;
+  Index left, right, stack[64], pos;
+  Seg pivot, temp;
+
+  left = 0;
+  pos = 0;
+  for (;;) {
+    while (left + 1 < len) {
+      if (pos >= sizeof stack / sizeof stack[0]) {
+	pos = 0;
+	len = stack[pos];  /* stack overflow, reset */
+      }
+      pivot = array[left + seed % (len - left)];
+      seed = seed * 69069 + 1;
+      stack[pos] = len;
+      ++pos;
+      right = left;
+      for (;;) {
+	while (shieldCacheEntryCompare(array[right],  pivot) < 0)
+	  ++right;
+	do
+	  --len;
+	while (shieldCacheEntryCompare(pivot, array[len]) < 0);
+	if (right >= len)
+	  break;
+	temp = array[right];
+	array[right] = array[len];
+	array[len] = temp;
+      }
+      ++len;
+    }
+    if (pos == 0)
+      break;
+    left = len;
+    --pos;
+    len = stack[pos];
+  } 
+}
+
+
 static void shieldCacheReset(Arena arena)
 {
   AVER(arena->shDepth == 0);
@@ -222,11 +263,7 @@ static void shieldFlushEntries(Arena arena)
   AVER(arena->shCache != NULL);
   AVER(arena->shCacheLength > 0);
 
-  /* FIXME: This needs to go through the plinth. */
-  /* FIXME: We probably can't use libc's qsort because we can't bound
-     its use of stack space. */
-  qsort(arena->shCache, arena->shCacheLimit, sizeof arena->shCache[0],
-        shieldCacheEntryCompare);
+  quicksort_iterative(arena->shCache, arena->shCacheLimit);
 
   seg = arena->shCache[0]; /* lowest address segment */
   if (seg) {

From eb8b31f059d240b400328fda215edb394385681f Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 17 Mar 2016 19:26:45 +0000
Subject: [PATCH 19/69] Tidying up quicksort into an mpm utility.

Copied from Perforce
 Change: 190171
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.c    | 48 +++++++++++++++++++++++++++++++++++
 mps/code/mpm.h    |  5 ++++
 mps/code/shield.c | 64 ++++++++++-------------------------------------
 3 files changed, 66 insertions(+), 51 deletions(-)

diff --git a/mps/code/mpm.c b/mps/code/mpm.c
index aba1ac2f5cb..3b912a54a02 100644
--- a/mps/code/mpm.c
+++ b/mps/code/mpm.c
@@ -645,6 +645,54 @@ Bool StringEqual(const char *s1, const char *s2)
 }
 
 
+/* QuickSort -- non-recursive bounded sort
+ *
+ * We can't rely on the standard library's qsort, which might have
+ * O(n) stack usage.  This version does not recurse.
+ */
+
+void QuickSort(void *array[], Count len,
+               QuickSortCompare compare, void *closure)
+{
+  static Index seed = 0x6A9D03;
+  Index left, right, stack[MPS_WORD_WIDTH], pos;
+  void *pivot, *temp;
+
+  left = 0;
+  pos = 0;
+  for (;;) {
+    while (left + 1 < len) {
+      if (pos >= sizeof stack / sizeof stack[0]) {
+	pos = 0;
+	len = stack[pos];  /* stack overflow, reset */
+      }
+      pivot = array[left + seed % (len - left)];
+      seed = seed * 69069 + 1;
+      stack[pos] = len;
+      ++pos;
+      right = left;
+      for (;;) {
+	while (compare(array[right],  pivot, closure) == CompareLESS)
+	  ++right;
+	do
+	  --len;
+	while (compare(pivot, array[len], closure) == CompareLESS);
+	if (right >= len)
+	  break;
+	temp = array[right];
+	array[right] = array[len];
+	array[len] = temp;
+      }
+      ++len;
+    }
+    if (pos == 0)
+      break;
+    left = len;
+    --pos;
+    len = stack[pos];
+  } 
+}
+
 
 /* C. COPYRIGHT AND LICENSE
  *
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index e2b0e57a8a2..01158fb0779 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -171,6 +171,11 @@ extern Res WriteF_firstformat_v(mps_lib_FILE *stream, Count depth,
 extern size_t StringLength(const char *s);
 extern Bool StringEqual(const char *s1, const char *s2);
 
+typedef Compare QuickSortCompare(void *left, void *right,
+                                 void *closure);
+extern void QuickSort(void *array[], Count length,
+                      QuickSortCompare compare, void *closure);
+
 
 /* Version Determination
  *
diff --git a/mps/code/shield.c b/mps/code/shield.c
index d889ae80240..884c13ce0e7 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -73,7 +73,6 @@
  */
 
 #include "mpm.h"
-#include "stdlib.h" /* For qsort, move */
 
 SRCID(shield, "$Id$");
 
@@ -179,63 +178,25 @@ static void shieldFlushEntry(Arena arena, Size i)
 }
 
 
-static int shieldCacheEntryCompare(Seg segA, Seg segB)
+static Compare shieldCacheEntryCompare(void *left, void *right, void *closure)
 {
+  Seg segA = left, segB = right;
   Addr baseA, baseB;
-  
-  AVERT(Seg, segA); /* FIXME: Might be critical? */
+
+  /* Making these CRITICAL had no effect on timings on LII6LL today.
+     RB 2016-03-17. */
+  AVERT(Seg, segA);
   AVERT(Seg, segB);
+  UNUSED(closure);
 
   baseA = SegBase(segA);
   baseB = SegBase(segB);
   if (baseA < baseB)
-    return -1;
+    return CompareLESS;
   if (baseA > baseB)
-    return 1;
+    return CompareGREATER;
   AVER(baseA == baseB);
-  return 0;
-}
-
-
-static void quicksort_iterative(Seg array[], Count len)
-{
-  static Index seed = 0x6A9D03;
-  Index left, right, stack[64], pos;
-  Seg pivot, temp;
-
-  left = 0;
-  pos = 0;
-  for (;;) {
-    while (left + 1 < len) {
-      if (pos >= sizeof stack / sizeof stack[0]) {
-	pos = 0;
-	len = stack[pos];  /* stack overflow, reset */
-      }
-      pivot = array[left + seed % (len - left)];
-      seed = seed * 69069 + 1;
-      stack[pos] = len;
-      ++pos;
-      right = left;
-      for (;;) {
-	while (shieldCacheEntryCompare(array[right],  pivot) < 0)
-	  ++right;
-	do
-	  --len;
-	while (shieldCacheEntryCompare(pivot, array[len]) < 0);
-	if (right >= len)
-	  break;
-	temp = array[right];
-	array[right] = array[len];
-	array[len] = temp;
-      }
-      ++len;
-    }
-    if (pos == 0)
-      break;
-    left = len;
-    --pos;
-    len = stack[pos];
-  } 
+  return CompareEQUAL;
 }
 
 
@@ -263,7 +224,8 @@ static void shieldFlushEntries(Arena arena)
   AVER(arena->shCache != NULL);
   AVER(arena->shCacheLength > 0);
 
-  quicksort_iterative(arena->shCache, arena->shCacheLimit);
+  QuickSort((void *)arena->shCache, arena->shCacheLimit,
+            shieldCacheEntryCompare, UNUSED_POINTER);
 
   seg = arena->shCache[0]; /* lowest address segment */
   if (seg) {
@@ -356,7 +318,7 @@ static void shieldCache(Arena arena, Seg seg)
     
     res = ControlAlloc(&p, arena, length * sizeof arena->shCache[0]);
     if (res != ResOK) {
-      AVER(res == ResMEMORY);
+      AVER(ResIsAllocFailure(res));
       /* Carry on with the existing cache. */
     } else {
       if (arena->shCacheLength > 0) {

From 91a08048b7c94441aceb413824ebbab1f44c520c Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 17 Mar 2016 20:04:26 +0000
Subject: [PATCH 20/69] Design documentation, commentary, and code tidying.

Copied from Perforce
 Change: 190172
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h     |   4 +-
 mps/code/shield.c     | 112 ++++++++++++++++++++----------------------
 mps/design/shield.txt |  49 ++++++++----------
 3 files changed, 75 insertions(+), 90 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index 530bf90cb6e..bfaaa2e6e4b 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -483,8 +483,8 @@
 
 /* Shield Configuration -- see <code/shield.c> */
 
-#define ShieldCacheSIZE  512
-#define ShieldDepthWIDTH 10
+#define ShieldCacheLENGTH  512  /* initial length of shield cache */
+#define ShieldDepthWIDTH     4  /* log2(max nested exposes + 1) */
 
 
 /* VM Configuration -- see <code/vm*.c> */
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 884c13ce0e7..8d0678f493a 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -209,70 +209,68 @@ static void shieldCacheReset(Arena arena)
 
 
 /* shieldFlushEntries -- flush cache coalescing protects
+ *
+ * Sort the shield cache into address order, then iterate over it
+ * coalescing protection work, in order to reduce the number of system
+ * calls to a minimum.  This is very important on OS X, where
+ * protection calls are extremely inefficient, but has no net gain on
+ * Windows.
  *
  * base, limit and mode represent outstanding protection to be done.
  */
 
 static void shieldFlushEntries(Arena arena)
 {
-  Addr base = 0, limit = 0;
-  AccessSet mode = 0;
+  Addr base = NULL, limit = NULL;
+  AccessSet mode;
   Seg seg;
   Size i;
-  if (arena->shDepth == 0)
+
+  if (arena->shDepth == 0) {
+    AVER(arena->shCacheLimit == 0);
     return;
+  }
+
   AVER(arena->shCache != NULL);
   AVER(arena->shCacheLength > 0);
 
   QuickSort((void *)arena->shCache, arena->shCacheLimit,
             shieldCacheEntryCompare, UNUSED_POINTER);
 
-  seg = arena->shCache[0]; /* lowest address segment */
-  if (seg) {
-    AVERT(Seg, seg);
-    arena->shCache[0] = NULL; /* just to make sure it isn't reused */
-
+  mode = AccessSetEMPTY;
+  for (i = 0; i < arena->shCacheLimit; ++i) {
     AVER(arena->shDepth > 0);
-    AVER(SegDepth(seg) > 0);
-    --arena->shDepth;
-    SegSetDepth(seg, SegDepth(seg) - 1);
 
-    if (!shieldSegIsSynced(seg)) {
-      SegSetPM(seg, SegSM(seg));
-      base = SegBase(seg);
-      limit = SegLimit(seg);
-      mode = SegSM(seg);
-    }
-  }
-  for (i=1; i < arena->shCacheLimit; ++i) {
-    if (arena->shDepth == 0)
-      break;
     seg = arena->shCache[i];
-    AVERT(Seg, seg);
-    arena->shCache[i] = NULL; /* just to make sure it isn't reused */
+    arena->shCache[i] = NULL; /* ensure it can't be reused */
 
-    AVER(arena->shDepth > 0);
+    AVERT(Seg, seg);
     AVER(SegDepth(seg) > 0);
+
     --arena->shDepth;
     SegSetDepth(seg, SegDepth(seg) - 1);
 
     if (!shieldSegIsSynced(seg)) {
+      AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
       SegSetPM(seg, SegSM(seg));
-      if (SegBase(seg) != limit || mode != SegSM(seg)) {
-        if (limit != 0) {
+      if (SegSM(seg) != mode || SegBase(seg) != limit) {
+        if (mode != AccessSetEMPTY) {
+          AVER(base != NULL);
+          AVER(base < limit);
           ProtSet(base, limit, mode);
         }
         base = SegBase(seg);
-        limit = SegLimit(seg);
         mode = SegSM(seg);
-      } else {
-        limit = SegLimit(seg);
       }
+      limit = SegLimit(seg);
     }
   }
-  if (limit != 0) {
+  if (mode != AccessSetEMPTY) {
+    AVER(base != NULL);
+    AVER(limit != NULL);
     ProtSet(base, limit, mode);
   }
+
   shieldCacheReset(arena);
 }
 
@@ -312,7 +310,7 @@ static void shieldCache(Arena arena, Seg seg)
     AVER(arena->shCacheI == arena->shCacheLength);
 
     if (arena->shCacheLength == 0)
-      length = ShieldCacheSIZE;
+      length = ShieldCacheLENGTH;
     else
       length = arena->shCacheLength * 2;
     
@@ -359,8 +357,10 @@ static void shieldCache(Arena arena, Seg seg)
      yet to be filled, and shCacheI is an uninitialized entry.
      Otherwise it's the tail end from last time around, and needs to
      be flushed. */
-  if (arena->shCacheLimit == arena->shCacheLength)
+  if (arena->shCacheLimit >= arena->shCacheLength) {
+    AVER_CRITICAL(arena->shCacheLimit == arena->shCacheLength);
     shieldFlushEntry(arena, arena->shCacheI);
+  }
 
   arena->shCache[arena->shCacheI] = seg;
   ++arena->shCacheI;
@@ -379,10 +379,12 @@ void (ShieldRaise) (Arena arena, Seg seg, AccessSet mode)
 
   AVERT(AccessSet, mode);
   AVER((SegSM(seg) & mode) == AccessSetEMPTY);
-  SegSetSM(seg, SegSM(seg) | mode); /* inv.prot.shield preserved */
+  
+  SegSetSM(seg, SegSM(seg) | mode); /* .inv.prot.shield preserved */
 
-  /* ensure inv.unsynced.suspended & inv.unsynced.depth */
+  /* ensure .inv.unsynced.suspended and .inv.unsynced.depth */
   shieldCache(arena, seg);
+
   AVERT(Arena, arena);
   AVERT(Seg, seg);
 }
@@ -393,10 +395,8 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
   /* Don't check seg or arena, see .seg.broken */
   AVERT(AccessSet, mode);
   AVER((SegSM(seg) & mode) == mode);
-  /* synced(seg) is not changed by the following
-   * preserving inv.unsynced.suspended
-   * Also inv.prot.shield preserved
-   */
+  /* synced(seg) is not changed by the following preserving
+     inv.unsynced.suspended Also inv.prot.shield preserved */
   SegSetSM(seg, SegSM(seg) & ~mode);
   protLower(arena, seg, mode);
   AVERT(Arena, arena);
@@ -419,28 +419,22 @@ void (ShieldEnter)(Arena arena)
 }
 
 
-/* .shield.flush: Flush empties the shield cache.
- * This needs to be called before segments are destroyed as there
- * may be references to them in the cache.
+/* ShieldFlush -- empty the shield cache
  *
- * The memory for the segment may become spare, and not released back to
- * the operating system. Since we keep track of protection on segments
- * and not grains we have no way of keeping track of the protection
- * state of spare grains. We therefore flush the protection to get it
- * back into the default state (unprotected).
+ * .shield.flush: Flush empties the shield cache.  This needs to be
+ * called before segments are destroyed as there may be references to
+ * them in the cache.
+ *
+ * The memory for the segment may become spare, and not released back
+ * to the operating system. Since we keep track of protection on
+ * segments and not grains we have no way of keeping track of the
+ * protection state of spare grains. We therefore flush the protection
+ * to get it back into the default state (unprotected).
  */
+
 void (ShieldFlush)(Arena arena)
 {
-  Size i;
-
-  if(1)
-    shieldFlushEntries(arena);
-
-  for (i = 0; i < arena->shCacheLimit; ++i) {
-    if (arena->shDepth == 0)
-      break;
-    shieldFlushEntry(arena, i);
-  }
+  shieldFlushEntries(arena);
 }
 
 
@@ -450,11 +444,11 @@ void (ShieldLeave)(Arena arena)
   AVER(arena->insideShield);
 
   ShieldFlush(arena);
-  /* Cache is empty so inv.outside.depth holds */
+  /* Cache is empty so .inv.outside.depth holds */
   AVER(arena->shDepth == 0);
 
-  /* Ensuring the mutator is running at this point
-   * guarantees inv.outside.running */
+  /* Ensuring the mutator is running at this point guarantees
+     .inv.outside.running */
   if (arena->suspended) {
     ThreadRingResume(ArenaThreadRing(arena), ArenaDeadRing(arena));
     arena->suspended = FALSE;
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 31648245ed1..42589a3c5e7 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -115,41 +115,27 @@ segment should be unprotected, and the Shield could re-instate
 hardware protection.
 
 However, as a performance-improving hysteresis, the Shield defers
-re-protection, maintaining a cache of the last ``ShieldCacheSIZE``
-times a segment no longer had a reason to be collector-accessible.
-Presence in the cache counts as a reason: segments in the cache have
-``seg->depth`` increased by one. As segments get pushed out of the
-cache, or at ``ShieldLeave()``, this artificial reason is
-decremented from ``seg->depth``, and (if ``seg->depth`` is now zero)
-the deferred reinstatement of hardware protection happens.
+re-protection, maintaining a cache reasons that a segment no longer
+had a reason to be collector-accessible.  Presence in the cache counts
+as a reason: segments in the cache have ``seg->depth`` increased by
+one. As segments get pushed out of the cache, or at ``ShieldLeave()``,
+this artificial reason is decremented from ``seg->depth``, and (if
+``seg->depth`` is now zero) the deferred reinstatement of hardware
+protection happens.
+
+This hysteresis allows the MPS to proceed with garbage collection
+during a pause without actually setting hardware protection until it
+returns to the mutator.  If a complete collection cycle occurs during
+one pause (a non-incremental collection), no system calls will be
+needed for collection barriers.  This is particularly important on
+operating systems where the protection is expensive and poorly
+implemented, such as OS X.
 
 So whenever hardware protection is temporarily removed to allow
 collector access, there is a *nurse* that will ensure this protection
 is re-established: the nurse is either the balancing ``ShieldCover()``
 call in collector code, or an entry in the shield cache.
 
-.. note::
-
-    1. Why is there a fixed-size cache? This is not the simple
-       approach! All we need is a chain of segs that might need their
-       hardware protection to be sync'd with their shield mode. Head
-       in the shield, and one pointer in each seg struct. I guess we
-       try hard to avoid bloating ``SegStruct`` (to maintain residency
-       in the processor cache). But is 16 the right size? A cache-miss
-       wastes two kernel calls.
-
-    2. I don't like the cache code. For example, why does
-       ``ShieldFlush()`` break out early if ``arena->shDepth`` is 0?
-       This should never happen until the cache is completely flushed,
-       that is, we have reached ``shCacheLimit``. Why does
-       ``ShieldFlush()`` not reset ``shCacheLimit``? Why does
-       ``flush()`` silently accept ``NULL`` cache entries?
-
-    3. Why is ``seg->depth`` never checked for overflow? It is only a
-       4-bit-wide bit field, currently.
-
-    Richard Kistruck, 2006-12-19.
-
 
 Initial ideas
 -------------
@@ -183,8 +169,13 @@ Document History
 
 - 2013-05-24 GDR_ Converted to reStructuredText.
 
+- 2016-03-17 RB_ Updated for dynamic cacheing and general code tidying
+  that has removed complaints.
+
 .. _GDR: http://www.ravenbrook.com/consultants/gdr/
 
+.. _RB: http://www.ravenbrook.com/consultants/rb/
+
 
 Copyright and License
 ---------------------

From 536960d0612e211b8a33581db092dda8227a81df Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Fri, 18 Mar 2016 14:50:11 +0000
Subject: [PATCH 21/69] Writing a clearer quicksort with assertions.

Copied from Perforce
 Change: 190181
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.c | 112 ++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 84 insertions(+), 28 deletions(-)

diff --git a/mps/code/mpm.c b/mps/code/mpm.c
index 3b912a54a02..d2c87d5038d 100644
--- a/mps/code/mpm.c
+++ b/mps/code/mpm.c
@@ -651,46 +651,102 @@ Bool StringEqual(const char *s1, const char *s2)
  * O(n) stack usage.  This version does not recurse.
  */
 
-void QuickSort(void *array[], Count len,
+#ifdef QUICKSORT_DEBUG
+static Bool quickSorted(void *array[], Count length,
+                        QuickSortCompare compare, void *closure)
+{
+  Index i;
+  if (length > 0) {
+    for (i = 0; i < length - 1; ++i) {
+      if (compare(array[i], array[i+1], closure) == CompareGREATER)
+        return FALSE;
+    }
+  }
+  return TRUE;
+}
+#endif
+
+void QuickSort(void *array[], Count length,
                QuickSortCompare compare, void *closure)
 {
   static Index seed = 0x6A9D03;
-  Index left, right, stack[MPS_WORD_WIDTH], pos;
+  struct {
+    Index left, right;
+  } stack[MPS_WORD_WIDTH];
+  Index left, right, sp, lo, hi, leftLimit, rightBase;
   void *pivot, *temp;
 
+  sp = 0;
   left = 0;
-  pos = 0;
+  right = length;
+
   for (;;) {
-    while (left + 1 < len) {
-      if (pos >= sizeof stack / sizeof stack[0]) {
-	pos = 0;
-	len = stack[pos];  /* stack overflow, reset */
-      }
-      pivot = array[left + seed % (len - left)];
+    while (right - left > 1) { /* no need to sort */
+      /* Pick a random pivot. */
+      pivot = array[left + seed % (right - left)];
       seed = seed * 69069 + 1;
-      stack[pos] = len;
-      ++pos;
-      right = left;
+
+      /* Hoare partition: scan from lo to hi, dividing it into elements
+         less than the pivot and elements greater or equal. */
+      lo = left;
+      hi = right;
       for (;;) {
-	while (compare(array[right],  pivot, closure) == CompareLESS)
-	  ++right;
-	do
-	  --len;
-	while (compare(pivot, array[len], closure) == CompareLESS);
-	if (right >= len)
-	  break;
-	temp = array[right];
-	array[right] = array[len];
-	array[len] = temp;
+        while (compare(array[lo], pivot, closure) == CompareLESS)
+          ++lo;
+        do
+          --hi;
+        while (compare(pivot, array[hi], closure) == CompareLESS);
+        if (lo >= hi)
+          break;
+        temp = array[hi];
+        array[hi] = array[lo];
+        array[lo] = temp;
+        ++lo; /* step over what we just swapped */
+      }
+
+      /* If we ended up at a pivot, then it is in its final position
+         and we must skip it to ensure termination.  This handles the case
+         where the pivot is at the start of the array, and one of the
+         partitions is the whole array, for example. */
+      if (lo == hi) {
+        AVER_CRITICAL(array[hi] == pivot); /* and it's in place */
+        leftLimit = lo;
+        rightBase = lo + 1;
+      } else {
+        AVER_CRITICAL(lo == hi + 1);
+        leftLimit = lo;
+        rightBase = lo;
+      }
+
+      /* Sort the smaller part now, so that we're sure to use at most
+         log2 length stack levels.  Push the larger part on the stack
+         for later. */
+      AVER_CRITICAL(sp < sizeof stack / sizeof stack[0]);
+      if (leftLimit - left < right - rightBase) {
+	stack[sp].left = rightBase;
+	stack[sp].right = right;
+	++sp;
+	right = leftLimit;
+      } else {
+	stack[sp].left = left;
+	stack[sp].right = leftLimit;
+	++sp;
+	left = rightBase;
       }
-      ++len;
     }
-    if (pos == 0)
+
+    if (sp == 0)
       break;
-    left = len;
-    --pos;
-    len = stack[pos];
-  } 
+
+    --sp;
+    left = stack[sp].left;
+    right = stack[sp].right;
+    AVER_CRITICAL(left < right); /* we do the smaller side immediately */
+  }
+
+#ifdef QUICKSORT_DEBUG
+  AVER(quickSorted(array, length, compare, closure));
+#endif
 }
 
 

From bb206eec148afc63ed7e84ac3bf9f951696fefb1 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Fri, 18 Mar 2016 15:37:53 +0000
Subject: [PATCH 22/69] Adding xci3ll.gmk to make it easier to test 32-bit
 builds on os x.

Copied from Perforce
 Change: 190184
 ServerID: perforce.ravenbrook.com
---
 mps/code/xci3ll.gmk | 72 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 72 insertions(+)
 create mode 100644 mps/code/xci3ll.gmk

diff --git a/mps/code/xci3ll.gmk b/mps/code/xci3ll.gmk
new file mode 100644
index 00000000000..a0af3b7079d
--- /dev/null
+++ b/mps/code/xci3ll.gmk
@@ -0,0 +1,72 @@
+# -*- makefile -*-
+#
+# xci3ll.gmk: BUILD FOR MAC OS X/i386/Clang PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2014 Ravenbrook Limited.  See end of file for license.
+#
+# .prefer.xcode: The documented and preferred way to develop the MPS
+# for this platform is to use the Xcode project (mps.xcodeproj). This
+# makefile provides a way to compile the MPS one source file at a
+# time, rather than all at once via mps.c (which can hide errors due
+# to missing headers).
+
+PFM = xci3ll
+
+MPMPF = \
+    lockix.c \
+    prmci3xc.c \
+    proti3.c \
+    protix.c \
+    protxc.c \
+    span.c \
+    ssixi3.c \
+    thxc.c \
+    vmix.c
+
+include ll.gmk
+
+CC = clang -arch i386
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+# All rights reserved.  This is an open source license.  Contact
+# Ravenbrook for commercial licensing options.
+# 
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+# 
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 
+# 3. Redistributions in any form must be accompanied by information on how
+# to obtain complete source code for this software and any accompanying
+# software that uses this software.  The source code must either be
+# included in the distribution or be available for no more than the cost
+# of distribution plus a nominal fee, and must be freely redistributable
+# under reasonable conditions.  For an executable file, complete source
+# code means the source code for all modules it contains. It does not
+# include source code for modules or files that typically accompany the
+# major components of the operating system on which the executable file
+# runs.
+# 
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+# PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
+# COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+# ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

From ed69abbd662eb555fbba81d4f738901dd2abb5fa Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 17 Mar 2016 20:06:41 +0000
Subject: [PATCH 23/69] Deferring non-urgent fixmes to todos.

Copied from Perforce
 Change: 190190
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 2 +-
 mps/code/trace.c  | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index 8d0678f493a..7fc9294b180 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -300,7 +300,7 @@ static void shieldCache(Arena arena, Seg seg)
   }
 
   /* Allocate shield cache if necessary. */
-  /* FIXME: This will try to extend the cache on every attempt, even
+  /* TODO: This will try to extend the cache on every attempt, even
      if it failed last time. That might be slow. */
   if (arena->shCacheI >= arena->shCacheLength) {
     void *p;
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 3c23e552990..1f3db0d3467 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -737,7 +737,7 @@ Res TraceCreate(Trace *traceReturn, Arena arena, int why)
   /* buffers under our feet. */
   /* @@@@ This is a short-term fix for request.dylan.160098_. */
   /* .. _request.dylan.160098: https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/dylan/160098 */
-  /* FIXME: Where is the corresponding ShieldResume? */
+  /* TODO: Where is the corresponding ShieldResume? */
   ShieldSuspend(arena);
 
   STATISTIC_STAT ({

From 20a34ca17f0cc68c42952c0a2eb767942e39e2d9 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 08:57:27 +0000
Subject: [PATCH 24/69] Importing good random number generator from testlib for
 use in quicksort and perhaps later in cuckoo hashing.

Copied from Perforce
 Change: 190191
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.c | 36 +++++++++++++++++++++++++++++++++---
 mps/code/mpm.h |  3 +++
 2 files changed, 36 insertions(+), 3 deletions(-)

diff --git a/mps/code/mpm.c b/mps/code/mpm.c
index d2c87d5038d..7d944ae57eb 100644
--- a/mps/code/mpm.c
+++ b/mps/code/mpm.c
@@ -645,6 +645,38 @@ Bool StringEqual(const char *s1, const char *s2)
 }
 
 
+/* Random -- a random number generator
+ *
+ * TODO: This is a copy of the generator from testlib.c, which has
+ * extensive notes and verification tests.  The notes need to go to a
+ * design document, and the tests to a test.
+ */
+
+static unsigned RandomSeed = 1;
+#define Random_m 2147483647UL
+#define Random_a 48271UL
+unsigned Random32(void)
+{
+  AVER(UINT_MAX >= 4294967295U);
+  /* requires m == 2^31-1, a < 2^16 */
+  unsigned bot = Random_a * (RandomSeed & 0x7FFF);
+  unsigned top = Random_a * (RandomSeed >> 15);
+  RandomSeed = bot + ((top & 0xFFFF) << 15) + (top >> 16);
+  if (RandomSeed > Random_m)
+    RandomSeed -= Random_m;
+  return RandomSeed;
+}
+
+Word RandomWord(void)
+{
+  Word word;
+  Index i;
+  for (i = 0; i < MPS_WORD_WIDTH; i += 31)
+    word = (word << 31) | Random32();
+  return word;
+}
+
+
 /* QuickSort -- non-recursive bounded sort
  *
  * We can't rely on the standard library's qsort, which might have
@@ -669,7 +701,6 @@ static Bool quickSorted(void *array[], Count length,
 void QuickSort(void *array[], Count length,
                QuickSortCompare compare, void *closure)
 {
-  static Index seed = 0x6A9D03;
   struct {
     Index left, right;
   } stack[MPS_WORD_WIDTH];
@@ -683,8 +714,7 @@ void QuickSort(void *array[], Count length,
   for (;;) {
     while (right - left > 1) { /* no need to sort */
       /* Pick a random pivot. */
-      pivot = array[left + seed % (right - left)];
-      seed = seed * 69069 + 1;
+      pivot = array[left + RandomWord() % (right - left)];
 
       /* Hoare partition: scan from lo to hi, dividing it into elements
          less than the pivot and elements greater or equal. */
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index 01158fb0779..96f28ffc840 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -171,6 +171,9 @@ extern Res WriteF_firstformat_v(mps_lib_FILE *stream, Count depth,
 extern size_t StringLength(const char *s);
 extern Bool StringEqual(const char *s1, const char *s2);
 
+extern unsigned Random32(void);
+extern Word RandomWord(void);
+
 typedef Compare QuickSortCompare(void *left, void *right,
                                  void *closure);
 extern void QuickSort(void *array[], Count length,

From 9172773f9ca78104a07f5c2f7cec1000f06744c3 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 10:15:10 +0000
Subject: [PATCH 25/69] Updating shield design and actually checking invariants
 in code.

Copied from Perforce
 Change: 190192
 ServerID: perforce.ravenbrook.com
---
 mps/code/global.c     | 38 +++++++++++++-----
 mps/code/seg.c        | 31 +++++++++------
 mps/code/shield.c     | 86 +++++++---------------------------------
 mps/design/shield.txt | 92 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 154 insertions(+), 93 deletions(-)

diff --git a/mps/code/global.c b/mps/code/global.c
index 6cba0902e95..d6522cc30e3 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -108,7 +108,6 @@ Bool GlobalsCheck(Globals arenaGlobals)
   TraceId ti;
   Trace trace;
   Index i;
-  Size depth;
   RefSet rs;
   Rank rank;
 
@@ -161,16 +160,35 @@ Bool GlobalsCheck(Globals arenaGlobals)
   CHECKL(arena->shCacheI <= arena->shCacheLimit);
   CHECKL(BoolCheck(arena->suspended));
 
-  depth = 0;
-  for (i = 0; i < arena->shCacheLimit; ++i) {
-    Seg seg = arena->shCache[i];
-    if (seg != NULL) {
-      CHECKD(Seg, seg);
-      depth += SegDepth(seg);
-    }
-  }
-  CHECKL(depth <= arena->shDepth);
+  /* The mutator is not suspended while outside the shield
+     (design.mps.shield.inv.outside.running). */
+  CHECKL(arena->insideShield || !arena->suspended);
 
+  /* If any segment is not synced, the mutator is suspended
+     (design.mps.shield.inv.unsynced.suspended). */
+  CHECKL(arena->shDepth == 0 || arena->suspended);
+
+  /* The total depth is zero while outside the shield
+     (design.mps.shield.inv.outside.depth). */
+  CHECKL(arena->insideShield || arena->shDepth == 0);
+
+  /* This is too expensive to check all the time since we have an
+     expanding shield cache that often has 16K elements instead of
+     16. */
+#ifdef AVER_AND_CHECK_ALL
+  {
+    Count depth = 0;
+    for (i = 0; i < arena->shCacheLimit; ++i) {
+      Seg seg = arena->shCache[i];
+      if (seg != NULL) {
+        CHECKD(Seg, seg);
+        depth += SegDepth(seg);
+      }
+    }
+    CHECKL(depth <= arena->shDepth);
+  }
+#endif
+  
   CHECKL(TraceSetCheck(arena->busyTraces));
   CHECKL(TraceSetCheck(arena->flippedTraces));
   CHECKL(TraceSetSuper(arena->busyTraces, arena->flippedTraces));
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 04785652e90..6a7e5e40fac 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -1,7 +1,7 @@
 /* seg.c: SEGMENTS
  *
  * $Id$
- * Copyright (c) 2001-2015 Ravenbrook Limited.  See end of file for license.
+ * Copyright (c) 2001-2016 Ravenbrook Limited.  See end of file for license.
  *
  * .design: The design for this module is <design/seg/>.
  *
@@ -16,14 +16,6 @@
  * all current GC features, and providing full backwards compatibility
  * with "old-style" segments.  It may be subclassed by clients of the
  * module.
- *
- * TRANSGRESSIONS
- *
- * .check.shield: The "pm", "sm", and "depth" fields are not checked by
- * SegCheck, because I haven't spent time working out the invariants.
- * We should certainly work them out, by studying <code/shield.c>, and
- * assert things about shielding, protection, shield cache consistency,
- * etc.  richard 1997-04-03
  */
 
 #include "tract.h"
@@ -223,6 +215,8 @@ static void SegFinish(Seg seg)
   seg->rankSet = RankSetEMPTY;
 
   /* See <code/shield.c#shield.flush> */
+  /* FIXME: We can probably avoid doing this for segments not in the
+     cache by checking their depth.  Zero depth => not in cache. */
   ShieldFlush(PoolArena(SegPool(seg)));
 
   limit = SegLimit(seg);
@@ -711,7 +705,22 @@ Bool SegCheck(Seg seg)
 
   CHECKD_NOSIG(Ring, &seg->poolRing);
    
-  /* "pm", "sm", and "depth" not checked.  See .check.shield. */
+  /* The protection mode is never more than the shield mode
+     (design.mps.shield.inv.prot.shield). */
+  CHECKL(BS_DIFF(seg->pm, seg->sm) == 0);
+  
+  /* An exposed segment is not protected
+     (design.mps.shield.inv.expose.prot). FIXME: Discovered to be
+     FALSE when raising the read barrier on a write-protected
+     segment. RB 2016-03-19 */
+  /* CHECKL(seg->depth == 0 || seg->pm == 0); */
+  /* FIXME: Wouldn't it be better to have a flag for "in cache" so
+     that depth > 0 => exposed? */
+
+  /* All unsynced segments have positive depth
+     (design.mps.shield.inv.unsynced.depth). */
+  CHECKL(seg->sm == seg->pm || seg->depth > 0);
+  
   CHECKL(RankSetCheck(seg->rankSet));
   if (seg->rankSet == RankSetEMPTY) {
     /* <design/seg/#field.rankSet.empty>: If there are no refs */
@@ -1674,7 +1683,7 @@ void SegClassMixInNoSplitMerge(SegClass class)
 
 /* C. COPYRIGHT AND LICENSE
  *
- * Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
+ * Copyright (C) 2001-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
  * All rights reserved.  This is an open source license.  Contact
  * Ravenbrook for commercial licensing options.
  * 
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 7fc9294b180..311984e9a21 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -5,71 +5,8 @@
  *
  * See: idea.shield, design.mps.shield.
  *
- * This implementation of the shield avoids suspending threads for
- * as long as possible.  When threads are suspended, it maintains a
- * cache of covered segments where the desired and actual protection
- * do not match.  This cache is flushed on leaving the shield.
- *
- *
- * Definitions
- *
- * .def.synced: a seg is synced if the prot and shield modes are the
- * same, and unsynced otherwise.
- * .def.depth: the depth of a segment is defined as
- *   depth == #exposes - #covers + #(in cache),  where
- *     #exposes = the total number of times the seg has been exposed
- *     #covers  = the total number of times the seg has been covered
- *     #(in cache) = the number of times the seg appears in the cache
- *   The cache is initially empty and Cover should not be called
- *   without a matching Expose, so this figure should always be
- *   non-negative.
- * .def.total.depth: The total depth is the sum of the depth over
- * all segments
- * .def.outside: being outside the shield is being between calls
- * to leave and enter, and similarly .def.inside: being inside the
- * shield is being between calls to enter and leave.
- * .def.suspended: suspended is true iff the mutator is suspended.
- * .def.shielded: a segment is shielded if the shield mode is non-zero.
- *
- *
- * Properties
- *
- * .prop.outside.running: The mutator may not be suspended while
- * outside the shield.
- * .prop.mutator.access: An attempt by the mutator to access
- * shielded memory must cause an ArenaAccess.
- * .prop.inside.access: Inside the shield it must be possible to access
- * all unshielded segments and all exposed segments.
- *
- *
- * Invariants
- *
- * These invariants are maintained by the code.
- *
- * .inv.outside.running: The mutator is not suspended while outside the
- * shield.
- * .inv.unsynced.suspended: If any segment is not synced,
- * the mutator is suspended.
- * .inv.unsynced.depth: All unsynced segments have positive depth.
- * .inv.outside.depth: The total depth is zero while outside the shield.
- * .inv.prot.shield: The prot mode is never more than the shield mode.
- * .inv.expose.prot: An exposed seg is not protected.
- *
- * Hints at proofs of properties from invariants
- *
- * inv.outside.running directly ensures prop.outside running.
- *
- * As the depth of a segment cannot be negative
- *   total depth == 0 => for all segments, depth == 0
- *                    => all segs are synced (by .inv.unsynced.depth)
- *
- * If the mutator is running then all segs must be synced
- * (.inv.unsynced.suspend).  Which means that the hardware protection
- * (prot mode) must reflect the software protection (shield mode).
- * Hence all shielded memory will be hardware protected while the
- * mutator is running.  This ensures .prop.mutator.access.
- *
- * inv.prot.shield and inv.expose.prot ensure prop.inside.access.
+ * IMPORTANT: This code is subtle and critical. Ensure you have read
+ * and understood design.mps.shield before you touch it.
  */
 
 #include "mpm.h"
@@ -79,27 +16,29 @@ SRCID(shield, "$Id$");
 
 /* shieldSegIsSynced -- is a segment synced?
  *
- * See .def.synced.
+ * See design.mps.shield.def.synced.
  */
 
 static Bool shieldSegIsSynced(Seg seg)
 {
-  AVERT_CRITICAL(Seg, seg);
+  AVER_CRITICAL(TESTT(Seg, seg));
   return SegSM(seg) == SegPM(seg);
 }
 
 
-/* shieldSync -- synchronize a segment's protection */
+/* shieldSync -- synchronize a segment's protection
+ *
+ * See design.mps.shield.inv.prot.shield.
+ */
 
 static void shieldSync(Arena arena, Seg seg)
 {
   AVERT(Arena, arena);
-  AVERT(Seg, seg);
+  AVER_CRITICAL(TESTT(Seg, seg));
 
   if (!shieldSegIsSynced(seg)) {
     ProtSet(SegBase(seg), SegLimit(seg), SegSM(seg));
     SegSetPM(seg, SegSM(seg));
-    /* See .inv.prot.shield. */
   }
 }
 
@@ -147,7 +86,7 @@ static void protLower(Arena arena, Seg seg, AccessSet mode)
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
   UNUSED(arena);
-  AVERT_CRITICAL(Seg, seg);
+  AVER_CRITICAL(TESTT(Seg, seg));
   AVERT_CRITICAL(AccessSet, mode);
 
   if (SegPM(seg) & mode) {
@@ -285,7 +224,8 @@ static void shieldCache(Arena arena, Seg seg)
 {
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
-  AVERT_CRITICAL(Seg, seg);
+  /* Can't fully check seg while we're enforcing its invariants. */
+  AVER_CRITICAL(TESTT(Seg, seg));
 
   if (shieldSegIsSynced(seg))
     return;
@@ -376,6 +316,8 @@ void (ShieldRaise) (Arena arena, Seg seg, AccessSet mode)
   /* this point (this function is called to enforce them) so we */
   /* can't check seg. Nor can we check arena as that checks the */
   /* segs in the cache. */
+  AVER(TESTT(Arena, arena));
+  AVER(TESTT(Seg, seg));
 
   AVERT(AccessSet, mode);
   AVER((SegSM(seg) & mode) == AccessSetEMPTY);
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 42589a3c5e7..09e57d43e18 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -137,6 +137,98 @@ is re-established: the nurse is either the balancing ``ShieldCover()``
 call in collector code, or an entry in the shield cache.
 
 
+Implementation
+--------------
+
+.impl.delay: The implementation of the shield avoids suspending
+threads for as long as possible.  When threads are suspended, it
+maintains a cache of covered segments where the desired and actual
+protection do not match.  This cache is flushed on leaving the shield.
+
+
+Definitions
+...........
+
+.def.synced: A seg is synced if the prot and shield modes are the
+same, and unsynced otherwise.
+
+.def.depth: The depth of a segment is defined as:
+
+  | depth ≔ #exposes − #covers + #(in cache),  where
+  |    #exposes = the total number of times the seg has been exposed
+  |    #covers  = the total number of times the seg has been covered
+  |    #(in cache) = the number of times the seg appears in the cache
+
+The cache is initially empty and Cover should not be called without a
+matching Expose, so this figure should always be non-negative.
+
+.def.total.depth: The total depth is the sum of the depth over
+all segments.
+
+.def.outside: Being outside the shield is being between calls to leave
+and enter, and similarly .def.inside: being inside the shield is being
+between calls to enter and leave.
+
+.def.suspended: Suspended is true iff the mutator is suspended.
+
+.def.shielded: A segment is shielded if the shield mode is non-zero.
+
+
+Properties
+..........
+
+.prop.outside.running: The mutator may not be suspended while outside
+the shield.
+
+.prop.mutator.access: An attempt by the mutator to access shielded
+memory must cause an ArenaAccess.
+
+.prop.inside.access: Inside the shield it must be possible to access
+all unshielded segments and all exposed segments.
+
+
+Invariants
+..........
+
+.inv.outside.running: The mutator is not suspended while outside the
+shield.
+
+.inv.unsynced.suspended: If any segment is not synced, the mutator is
+suspended.
+
+.inv.unsynced.depth: All unsynced segments have positive depth.
+
+.inv.outside.depth: The total depth is zero while outside the shield.
+
+.inv.prot.shield: The prot mode is never more than the shield mode.
+
+.inv.expose.prot: An exposed seg is not protected.
+
+
+Proof Hints
+...........
+
+Hints at proofs of properties from invariants.
+
+.proof.outside: .inv.outside.running directly ensures .prop.outside
+running.
+
+.proof.sync: As the depth of a segment cannot be negative
+
+  | total depth = 0
+  |   ⇒ for all segments, depth = 0
+  |   ⇒ all segs are synced (by .inv.unsynced.depth)
+
+.proof.access: If the mutator is running then all segs must be synced
+(.inv.unsynced.suspend).  Which means that the hardware protection
+(.prot mode) must reflect the software protection (shield mode).
+Hence all shielded memory will be hardware protected while the mutator
+is running.  This ensures .prop.mutator.access.
+
+.proof.inside: .inv.prot.shield and .inv.expose.prot ensure
+.prop.inside.access.
+
+
 Initial ideas
 -------------
 

From 2c69ff0ce55e6ae17832c6e610c7c1873907618f Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 10:19:14 +0000
Subject: [PATCH 26/69] Avoid shield flush when finishing a segment that isn't
 in the cache.

Copied from Perforce
 Change: 190193
 ServerID: perforce.ravenbrook.com
---
 mps/code/seg.c | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/mps/code/seg.c b/mps/code/seg.c
index 6a7e5e40fac..2a76f46685d 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -205,6 +205,11 @@ static void SegFinish(Seg seg)
   AVERT(SegClass, class);
 
   arena = PoolArena(SegPool(seg));
+
+  /* TODO: It would be good to avoid deprotecting segments eagerly
+     when we free them, especially if they're going to be
+     unmapped. This would require tracking of protection independent
+     of the existence of a SegStruct. */
   if (seg->sm != AccessSetEMPTY) {
     ShieldLower(arena, seg, seg->sm);
   }
@@ -215,9 +220,8 @@ static void SegFinish(Seg seg)
   seg->rankSet = RankSetEMPTY;
 
   /* See <code/shield.c#shield.flush> */
-  /* FIXME: We can probably avoid doing this for segments not in the
-     cache by checking their depth.  Zero depth => not in cache. */
-  ShieldFlush(PoolArena(SegPool(seg)));
+  if (seg->depth > 0)
+    ShieldFlush(PoolArena(SegPool(seg)));
 
   limit = SegLimit(seg);
   

From ff69c9af041da2feee2a77b841e94bce96f02be9 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 13:42:09 +0000
Subject: [PATCH 27/69] Separating flag for segment in shield cache from depth,
 clarifying code and optimising segfree somewhat.

Copied from Perforce
 Change: 190194
 ServerID: perforce.ravenbrook.com
---
 mps/code/check.h      |  11 +++-
 mps/code/global.c     |   8 ++-
 mps/code/mpmst.h      |   3 +-
 mps/code/seg.c        |  17 +++----
 mps/code/shield.c     | 115 ++++++++++++++++++++++++------------------
 mps/design/shield.txt |  47 ++++++++++-------
 6 files changed, 116 insertions(+), 85 deletions(-)

diff --git a/mps/code/check.h b/mps/code/check.h
index a2450bebd9a..2a08160040e 100644
--- a/mps/code/check.h
+++ b/mps/code/check.h
@@ -39,6 +39,15 @@
 #include "mpslib.h"
 
 
+/* FIXME: to config.h? */
+
+#if defined(MPS_BUILD_LL) || defined(MPS_BUILD_GC)
+#define UNEXPECTED(expr)  __builtin_expect((expr) != 0, TRUE)
+#else
+#define UNEXPECTED(expr)  (expr)
+#endif
+
+
 /* ASSERT -- basic assertion
  *
  * The ASSERT macro is equivalent to the ISO C assert() except that it is
@@ -51,7 +60,7 @@
 
 #define ASSERT(cond, condstring) \
   BEGIN \
-    if (cond) NOOP; else \
+    if (UNEXPECTED(cond)) NOOP; else                           \
       mps_lib_assert_fail(MPS_FILE, __LINE__, (condstring)); \
   END
 
diff --git a/mps/code/global.c b/mps/code/global.c
index d6522cc30e3..ce8885daf04 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -175,15 +175,13 @@ Bool GlobalsCheck(Globals arenaGlobals)
   /* This is too expensive to check all the time since we have an
      expanding shield cache that often has 16K elements instead of
      16. */
-#ifdef AVER_AND_CHECK_ALL
+#if defined(AVER_AND_CHECK_ALL)
   {
     Count depth = 0;
     for (i = 0; i < arena->shCacheLimit; ++i) {
       Seg seg = arena->shCache[i];
-      if (seg != NULL) {
-        CHECKD(Seg, seg);
-        depth += SegDepth(seg);
-      }
+      CHECKD(Seg, seg);
+      depth += SegDepth(seg);
     }
     CHECKL(depth <= arena->shDepth);
   }
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index ed28ce66214..1ee48063c8d 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -253,7 +253,8 @@ typedef struct SegStruct {      /* segment structure */
   Tract firstTract;             /* first tract of segment */
   RingStruct poolRing;          /* link in list of segs in pool */
   Addr limit;                   /* limit of segment */
-  unsigned depth : ShieldDepthWIDTH; /* see <code/shield.c#def.depth> */
+  unsigned depth : ShieldDepthWIDTH; /* see design.mps.shield.def.depth */
+  BOOLFIELD(cached);            /* in shield cache? */
   AccessSet pm : AccessLIMIT;   /* protection mode, <code/shield.c> */
   AccessSet sm : AccessLIMIT;   /* shield mode, <code/shield.c> */
   TraceSet grey : TraceLIMIT;   /* traces for which seg is grey */
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 2a76f46685d..8f3fe37dcd7 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -150,6 +150,7 @@ static Res SegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
   seg->pm = AccessSetEMPTY;
   seg->sm = AccessSetEMPTY;
   seg->depth = 0;
+  seg->cached = FALSE;
   seg->firstTract = NULL;
 
   seg->sig = SegSig;  /* set sig now so tract checks will see it */
@@ -220,8 +221,10 @@ static void SegFinish(Seg seg)
   seg->rankSet = RankSetEMPTY;
 
   /* See <code/shield.c#shield.flush> */
-  if (seg->depth > 0)
+  AVER(seg->depth == 0);
+  if (seg->cached)
     ShieldFlush(PoolArena(SegPool(seg)));
+  AVER(seg->cached == FALSE);
 
   limit = SegLimit(seg);
   
@@ -713,17 +716,9 @@ Bool SegCheck(Seg seg)
      (design.mps.shield.inv.prot.shield). */
   CHECKL(BS_DIFF(seg->pm, seg->sm) == 0);
   
-  /* An exposed segment is not protected
-     (design.mps.shield.inv.expose.prot). FIXME: Discovered to be
-     FALSE when raising the read barrier on a write-protected
-     segment. RB 2016-03-19 */
-  /* CHECKL(seg->depth == 0 || seg->pm == 0); */
-  /* FIXME: Wouldn't it be better to have a flag for "in cache" so
-     that depth > 0 => exposed? */
-
-  /* All unsynced segments have positive depth
+  /* All unsynced segments have positive depth or are in the cache
      (design.mps.shield.inv.unsynced.depth). */
-  CHECKL(seg->sm == seg->pm || seg->depth > 0);
+  CHECKL(seg->sm == seg->pm || seg->depth > 0 || seg->cached);
   
   CHECKL(RankSetCheck(seg->rankSet));
   if (seg->rankSet == RankSetEMPTY) {
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 311984e9a21..af1ad934d67 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -25,6 +25,12 @@ static Bool shieldSegIsSynced(Seg seg)
   return SegSM(seg) == SegPM(seg);
 }
 
+static Bool SegIsExposed(Seg seg)
+{
+  AVER_CRITICAL(TESTT(Seg, seg));
+  return seg->depth > 0;
+}
+
 
 /* shieldSync -- synchronize a segment's protection
  *
@@ -77,6 +83,7 @@ void (ShieldResume)(Arena arena)
   AVER(arena->insideShield);
   AVER(arena->suspended);
   /* It is only correct to actually resume the mutator here if shDepth is 0 */
+  /* TODO: Consider actually doing that. */
 }
 
 
@@ -89,34 +96,35 @@ static void protLower(Arena arena, Seg seg, AccessSet mode)
   AVER_CRITICAL(TESTT(Seg, seg));
   AVERT_CRITICAL(AccessSet, mode);
 
-  if (SegPM(seg) & mode) {
-    SegSetPM(seg, SegPM(seg) & ~mode);
+  if (BS_INTER(SegPM(seg), mode) != 0) {
+    SegSetPM(seg, BS_DIFF(SegPM(seg), mode));
     ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg));
   }
 }
 
 
-static void shieldFlushEntry(Arena arena, Size i)
+/* shieldFlushEntry -- flush a single entry from the cache */
+
+static void shieldFlushEntry(Arena arena, Index i)
 {
   Seg seg;
-  AVERT(Arena, arena);
-  AVER(i < arena->shCacheLimit);
 
+  AVERT(Arena, arena);
   seg = arena->shCache[i];
   AVERT(Seg, seg);
 
-  AVER(arena->shDepth > 0);
-  AVER(SegDepth(seg) > 0);
-  --arena->shDepth;
-  SegSetDepth(seg, SegDepth(seg) - 1);
+  AVER(i < arena->shCacheLimit);
+  AVER(seg->cached);
 
-  if (SegDepth(seg) == 0)
+  if (!SegIsExposed(seg))
     shieldSync(arena, seg);
 
-  arena->shCache[i] = NULL; /* just to make sure it gets overwritten */
+  arena->shCache[i] = NULL; /* just to make sure it can't be reused */
 }
 
 
+/* shieldCacheEntryCompare -- comparison for cache sorting */
+
 static Compare shieldCacheEntryCompare(void *left, void *right, void *closure)
 {
   Seg segA = left, segB = right;
@@ -162,32 +170,25 @@ static void shieldFlushEntries(Arena arena)
 {
   Addr base = NULL, limit = NULL;
   AccessSet mode;
-  Seg seg;
-  Size i;
+  Index i;
 
-  if (arena->shDepth == 0) {
-    AVER(arena->shCacheLimit == 0);
+  if (arena->shCacheLength == 0) {
+    AVER(arena->shCache == NULL);
     return;
   }
 
-  AVER(arena->shCache != NULL);
-  AVER(arena->shCacheLength > 0);
-
   QuickSort((void *)arena->shCache, arena->shCacheLimit,
             shieldCacheEntryCompare, UNUSED_POINTER);
 
   mode = AccessSetEMPTY;
   for (i = 0; i < arena->shCacheLimit; ++i) {
-    AVER(arena->shDepth > 0);
-
-    seg = arena->shCache[i];
-    arena->shCache[i] = NULL; /* ensure it can't be reused */
+    Seg seg = arena->shCache[i];
 
     AVERT(Seg, seg);
-    AVER(SegDepth(seg) > 0);
 
-    --arena->shDepth;
-    SegSetDepth(seg, SegDepth(seg) - 1);
+    AVER(seg->cached);
+    seg->cached = FALSE;
+    arena->shCache[i] = NULL; /* ensure it can't be reused */
 
     if (!shieldSegIsSynced(seg)) {
       AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
@@ -216,8 +217,8 @@ static void shieldFlushEntries(Arena arena)
 
 /* shieldCache -- consider adding a segment to the cache
  *
- * If the segment is out of sync, either sync it, or ensure depth > 0,
- * and the arena is suspended.
+ * If the segment is out of sync, either sync it, or ensure it is
+ * cached and the arena is suspended.
  */
 
 static void shieldCache(Arena arena, Seg seg)
@@ -227,10 +228,10 @@ static void shieldCache(Arena arena, Seg seg)
   /* Can't fully check seg while we're enforcing its invariants. */
   AVER_CRITICAL(TESTT(Seg, seg));
 
-  if (shieldSegIsSynced(seg))
+  if (shieldSegIsSynced(seg) || seg->cached)
     return;
-  
-  if (SegDepth(seg) > 0) { /* already in the cache or exposed? */
+
+  if (SegIsExposed(seg)) {
     /* This can occur if the mutator isn't suspended, we expose a
        segment, then raise the shield on it.  In this case, the
        mutator isn't allowed to see the segment, but we don't need to
@@ -279,11 +280,6 @@ static void shieldCache(Arena arena, Seg seg)
     return;
   }
 
-  SegSetDepth(seg, SegDepth(seg) + 1);
-  AVER_CRITICAL(SegDepth(seg) > 0); /* overflow */
-  ++arena->shDepth;
-  AVER_CRITICAL(arena->shDepth > 0); /* overflow */
-
   AVER_CRITICAL(arena->shCacheLimit <= arena->shCacheLength);
   AVER_CRITICAL(arena->shCacheI <= arena->shCacheLimit);
 
@@ -304,13 +300,14 @@ static void shieldCache(Arena arena, Seg seg)
 
   arena->shCache[arena->shCacheI] = seg;
   ++arena->shCacheI;
+  seg->cached = TRUE;
 
   if (arena->shCacheI >= arena->shCacheLimit)
     arena->shCacheLimit = arena->shCacheI;
 }
 
 
-void (ShieldRaise) (Arena arena, Seg seg, AccessSet mode)
+void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
 {
   /* .seg.broken: Seg's shield invariants may not be true at */
   /* this point (this function is called to enforce them) so we */
@@ -327,6 +324,7 @@ void (ShieldRaise) (Arena arena, Seg seg, AccessSet mode)
   /* ensure .inv.unsynced.suspended and .inv.unsynced.depth */
   shieldCache(arena, seg);
 
+  /* Check cache and segment consistency. */
   AVERT(Arena, arena);
   AVERT(Seg, seg);
 }
@@ -334,13 +332,17 @@ void (ShieldRaise) (Arena arena, Seg seg, AccessSet mode)
 
 void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 {
-  /* Don't check seg or arena, see .seg.broken */
+  AVERT(Arena, arena);
+  AVER(TESTT(Seg, seg));
   AVERT(AccessSet, mode);
-  AVER((SegSM(seg) & mode) == mode);
+  AVER(BS_INTER(SegSM(seg), mode) == mode);
+  
   /* synced(seg) is not changed by the following preserving
      inv.unsynced.suspended Also inv.prot.shield preserved */
-  SegSetSM(seg, SegSM(seg) & ~mode);
+  SegSetSM(seg, BS_DIFF(SegSM(seg), mode));
   protLower(arena, seg, mode);
+
+  /* Check cache and segment consistency. */
   AVERT(Arena, arena);
   AVERT(Seg, seg);
 }
@@ -352,8 +354,6 @@ void (ShieldEnter)(Arena arena)
   AVER(!arena->insideShield);
   AVER(arena->shDepth == 0);
   AVER(!arena->suspended);
-  AVER(arena->shCacheLimit <= arena->shCacheLength);
-  AVER(arena->shCacheI <= arena->shCacheLimit);
 
   shieldCacheReset(arena);
 
@@ -386,6 +386,7 @@ void (ShieldLeave)(Arena arena)
   AVER(arena->insideShield);
 
   ShieldFlush(arena);
+
   /* Cache is empty so .inv.outside.depth holds */
   AVER(arena->shDepth == 0);
 
@@ -396,6 +397,20 @@ void (ShieldLeave)(Arena arena)
     arena->suspended = FALSE;
   }
   arena->insideShield = FALSE;
+
+#ifdef SHIELD_DEBUG
+  {
+    Seg seg;
+    if (SegFirst(&seg, arena))
+      do {
+        AVER(!seg->cached);
+        AVER(shieldSegIsSynced(seg));
+        /* You can directly set protections here to see if it makes a
+           difference. */
+        ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg));
+      } while(SegNext(&seg, arena, seg));
+  }
+#endif
 }
 
 
@@ -434,31 +449,33 @@ void (ShieldExpose)(Arena arena, Seg seg)
   AVER_CRITICAL(arena->insideShield);
 
   SegSetDepth(seg, SegDepth(seg) + 1);
+  AVER_CRITICAL(SegDepth(seg) > 0); /* overflow */
   ++arena->shDepth;
-  /* <design/trace/#fix.noaver> */
-  AVER_CRITICAL(arena->shDepth > 0);
-  AVER_CRITICAL(SegDepth(seg) > 0);
-  if (SegPM(seg) & mode)
+  AVER_CRITICAL(arena->shDepth > 0); /* overflow */
+  
+  if (BS_INTER(SegPM(seg), mode))
     ShieldSuspend(arena);
 
-  /* This ensures inv.expose.prot */
+  /* Ensure design.mps.shield.inv.expose.prot. */
   protLower(arena, seg, mode);
 }
 
 
+/* ShieldCover -- declare MPS no longer needs access to seg */
+
 void (ShieldCover)(Arena arena, Seg seg)
 {
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
   AVERT_CRITICAL(Seg, seg);
   AVER_CRITICAL(SegPM(seg) == AccessSetEMPTY);
-
-  AVER_CRITICAL(arena->shDepth > 0);
+ 
   AVER_CRITICAL(SegDepth(seg) > 0);
   SegSetDepth(seg, SegDepth(seg) - 1);
+  AVER_CRITICAL(arena->shDepth > 0);
   --arena->shDepth;
 
-  /* ensure inv.unsynced.depth */
+  /* Ensure design.mps.shield.inv.unsynced.depth. */
   shieldCache(arena, seg);
 }
 
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 09e57d43e18..c3369750789 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -115,13 +115,9 @@ segment should be unprotected, and the Shield could re-instate
 hardware protection.
 
 However, as a performance-improving hysteresis, the Shield defers
-re-protection, maintaining a cache reasons that a segment no longer
-had a reason to be collector-accessible.  Presence in the cache counts
-as a reason: segments in the cache have ``seg->depth`` increased by
-one. As segments get pushed out of the cache, or at ``ShieldLeave()``,
-this artificial reason is decremented from ``seg->depth``, and (if
-``seg->depth`` is now zero) the deferred reinstatement of hardware
-protection happens.
+re-protection, maintaining a cache of segments that no longer have a
+reason to be collector-accessible.  While a segment is in the cache,
+it has ``seg->cached`` set to TRUE.
 
 This hysteresis allows the MPS to proceed with garbage collection
 during a pause without actually setting hardware protection until it
@@ -154,20 +150,22 @@ same, and unsynced otherwise.
 
 .def.depth: The depth of a segment is defined as:
 
-  | depth ≔ #exposes − #covers + #(in cache),  where
+  | depth ≔ #exposes − #covers, where
   |    #exposes = the total number of times the seg has been exposed
   |    #covers  = the total number of times the seg has been covered
-  |    #(in cache) = the number of times the seg appears in the cache
 
-The cache is initially empty and Cover should not be called without a
-matching Expose, so this figure should always be non-negative.
+The cache is initially empty and ``ShieldCover`` should not be called
+without a matching ``ShieldExpose``, so this figure should always be
+non-negative.
 
-.def.total.depth: The total depth is the sum of the depth over
-all segments.
+.def.total.depth: The total depth is the sum of the depth over all
+segments.
 
-.def.outside: Being outside the shield is being between calls to leave
-and enter, and similarly .def.inside: being inside the shield is being
-between calls to enter and leave.
+.def.outside: Being outside the shield is being between calls to
+``ShieldLeave`` and ``ShieldEnter``, and similarly .def.inside: being
+inside the shield is being between calls to ``ShieldEnter`` and
+``ShieldLeave``.  [In a multi-threaded MPS this would be per-thread.
+RB 2016-03-18]
 
 .def.suspended: Suspended is true iff the mutator is suspended.
 
@@ -196,13 +194,15 @@ shield.
 .inv.unsynced.suspended: If any segment is not synced, the mutator is
 suspended.
 
-.inv.unsynced.depth: All unsynced segments have positive depth.
+.inv.unsynced.depth: All unsynced segments have positive depth or are
+in the cache.
 
 .inv.outside.depth: The total depth is zero while outside the shield.
 
 .inv.prot.shield: The prot mode is never more than the shield mode.
 
-.inv.expose.prot: An exposed seg is not protected.
+.inv.expose.prot: An exposed seg is not protected in the mode it was
+exposed with.
 
 
 Proof Hints
@@ -236,6 +236,17 @@ _`.ideas`: There never was an initial design document, but
 [RB_1995-11-29]_ and [RB_1995-11-30]_ contain some initial ideas.
 
 
+Improvement Ideas
+-----------------
+
+.improv.mass-expose: If protection calls have a high overhead it might
+be good to pre-emptively unprotect large ranges of memory when we
+expose one segment.  With the current design this would mean
+discovering adjacent shielded segments and adding them to the cache.
+The collector should take advantage of this by preferentially scanning
+exposed segments during a pause.
+
+
 References
 ----------
 

From d280ff5c040b10acffec7b2ae0dfc5070bbc9ab0 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 14:11:26 +0000
Subject: [PATCH 28/69] Fixing missing cache flag reset when a single entry is
 removed in low memory situations.

Copied from Perforce
 Change: 190199
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 88 ++++++++++++++++++++++++++++-------------------
 1 file changed, 53 insertions(+), 35 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index af1ad934d67..9aae39ecf84 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -103,23 +103,27 @@ static void protLower(Arena arena, Seg seg, AccessSet mode)
 }
 
 
+static Seg shieldDecache(Arena arena, Index i)
+{
+  Seg seg;
+  AVER(i < arena->shCacheLimit);
+  seg = arena->shCache[i];
+  AVERT(Seg, seg);
+  AVER(seg->cached);
+  arena->shCache[i] = NULL;
+  seg->cached = FALSE;
+  return seg;
+}
+
+
 /* shieldFlushEntry -- flush a single entry from the cache */
 
 static void shieldFlushEntry(Arena arena, Index i)
 {
-  Seg seg;
-
-  AVERT(Arena, arena);
-  seg = arena->shCache[i];
-  AVERT(Seg, seg);
-
-  AVER(i < arena->shCacheLimit);
-  AVER(seg->cached);
+  Seg seg = shieldDecache(arena, i);
 
   if (!SegIsExposed(seg))
     shieldSync(arena, seg);
-
-  arena->shCache[i] = NULL; /* just to make sure it can't be reused */
 }
 
 
@@ -182,14 +186,7 @@ static void shieldFlushEntries(Arena arena)
 
   mode = AccessSetEMPTY;
   for (i = 0; i < arena->shCacheLimit; ++i) {
-    Seg seg = arena->shCache[i];
-
-    AVERT(Seg, seg);
-
-    AVER(seg->cached);
-    seg->cached = FALSE;
-    arena->shCache[i] = NULL; /* ensure it can't be reused */
-
+    Seg seg = shieldDecache(arena, i);
     if (!shieldSegIsSynced(seg)) {
       AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
       SegSetPM(seg, SegSM(seg));
@@ -361,6 +358,34 @@ void (ShieldEnter)(Arena arena)
 }
 
 
+#if defined(SHIELD_DEBUG)
+static void shieldDebugCheck(Arena arena)
+{
+  Seg seg;
+  Count cached = 0;
+
+  AVERT(Arena, arena);
+  AVER(arena->insideShield || arena->shCacheLimit == 0);
+
+  if (SegFirst(&seg, arena))
+    do {
+      if (arena->shCacheLimit == 0) {
+        AVER(!seg->cached);
+        AVER(shieldSegIsSynced(seg));
+        /* You can directly set protections here to see if it makes a
+           difference. */
+        /* ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg)); */
+      } else {
+        if (seg->cached)
+          ++cached;
+      }
+    } while(SegNext(&seg, arena, seg));
+
+  AVER(cached == arena->shCacheLimit);
+}
+#endif
+
+
 /* ShieldFlush -- empty the shield cache
  *
  * .shield.flush: Flush empties the shield cache.  This needs to be
@@ -376,7 +401,15 @@ void (ShieldEnter)(Arena arena)
 
 void (ShieldFlush)(Arena arena)
 {
+#ifdef SHIELD_DEBUG
+  shieldDebugCheck(arena);
+#endif
   shieldFlushEntries(arena);
+  /* Cache is empty so .inv.outside.depth holds */
+  AVER(arena->shDepth == 0);
+#ifdef SHIELD_DEBUG
+  shieldDebugCheck(arena);
+#endif
 }
 
 
@@ -387,33 +420,18 @@ void (ShieldLeave)(Arena arena)
 
   ShieldFlush(arena);
 
-  /* Cache is empty so .inv.outside.depth holds */
-  AVER(arena->shDepth == 0);
-
   /* Ensuring the mutator is running at this point guarantees
      .inv.outside.running */
   if (arena->suspended) {
     ThreadRingResume(ArenaThreadRing(arena), ArenaDeadRing(arena));
     arena->suspended = FALSE;
   }
-  arena->insideShield = FALSE;
 
-#ifdef SHIELD_DEBUG
-  {
-    Seg seg;
-    if (SegFirst(&seg, arena))
-      do {
-        AVER(!seg->cached);
-        AVER(shieldSegIsSynced(seg));
-        /* You can directly set protections here to see if it makes a
-           difference. */
-        ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg));
-      } while(SegNext(&seg, arena, seg));
-  }
-#endif
+  arena->insideShield = FALSE;
 }
 
 
+
 /* ShieldExpose -- allow the MPS access to a segment while denying the mutator
  *
  * The MPS currently does not collect concurrently, however the only thing

From ca6aa07632ab89a7208e9e3c8c9e962abee51953 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 14:47:54 +0000
Subject: [PATCH 29/69] Tidying up, especially special assertions.

Copied from Perforce
 Change: 190204
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 124 ++++++++++++++++++++++++++++------------------
 1 file changed, 77 insertions(+), 47 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index 9aae39ecf84..88959cfecfe 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -1,7 +1,7 @@
 /* shield.c: SHIELD IMPLEMENTATION
  *
  * $Id$
- * Copyright (c) 2001-2015 Ravenbrook Limited.  See end of file for license.
+ * Copyright (c) 2001-2016 Ravenbrook Limited.  See end of file for license.
  *
  * See: idea.shield, design.mps.shield.
  *
@@ -14,20 +14,39 @@
 SRCID(shield, "$Id$");
 
 
-/* shieldSegIsSynced -- is a segment synced?
+/* SHIELD_AVER -- transgressive argument checking
+ *
+ * .trans.check: A number of shield functions cannot do normal
+ * argument checking with AVERT because (for example) SegCheck checks
+ * the shield invariants, and it is these functions that are enforcing
+ * them.  Instead, we AVER(TESTT(Seg, seg)) to check the type
+ * signature but not the contents.
+ */
+
+#define SHIELD_AVERT(type, exp) AVER(TESTT(type, exp))
+#define SHIELD_AVERT_CRITICAL(type, exp) AVER_CRITICAL(TESTT(type, exp))
+
+
+/* SegIsSynced -- is a segment synced?
  *
  * See design.mps.shield.def.synced.
  */
 
-static Bool shieldSegIsSynced(Seg seg)
+static Bool SegIsSynced(Seg seg)
 {
-  AVER_CRITICAL(TESTT(Seg, seg));
+  SHIELD_AVERT_CRITICAL(Seg, seg);
   return SegSM(seg) == SegPM(seg);
 }
 
+
+/* SegIsExposed -- is a segment exposed?
+ *
+ * See design.mps.shield.def.exposed.
+ */
+
 static Bool SegIsExposed(Seg seg)
 {
-  AVER_CRITICAL(TESTT(Seg, seg));
+  SHIELD_AVERT_CRITICAL(Seg, seg);
   return seg->depth > 0;
 }
 
@@ -40,9 +59,9 @@ static Bool SegIsExposed(Seg seg)
 static void shieldSync(Arena arena, Seg seg)
 {
   AVERT(Arena, arena);
-  AVER_CRITICAL(TESTT(Seg, seg));
+  SHIELD_AVERT_CRITICAL(Seg, seg);
 
-  if (!shieldSegIsSynced(seg)) {
+  if (!SegIsSynced(seg)) {
     ProtSet(SegBase(seg), SegLimit(seg), SegSM(seg));
     SegSetPM(seg, SegSM(seg));
   }
@@ -87,22 +106,28 @@ void (ShieldResume)(Arena arena)
 }
 
 
-/* This ensures actual prot mode does not include mode */
-static void protLower(Arena arena, Seg seg, AccessSet mode)
+/* shieldProtLower -- reduce protection on a segment
+ *
+ * This ensures actual prot mode does not include mode.
+ */
+
+static void shieldProtLower(Arena arena, Seg seg, AccessSet mode)
 {
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
   UNUSED(arena);
-  AVER_CRITICAL(TESTT(Seg, seg));
+  SHIELD_AVERT_CRITICAL(Seg, seg);
   AVERT_CRITICAL(AccessSet, mode);
 
-  if (BS_INTER(SegPM(seg), mode) != 0) {
+  if (BS_INTER(SegPM(seg), mode) != AccessSetEMPTY) {
     SegSetPM(seg, BS_DIFF(SegPM(seg), mode));
     ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg));
   }
 }
 
 
+/* shieldDecache -- remove a segment from the shield cache */
+
 static Seg shieldDecache(Arena arena, Index i)
 {
   Seg seg;
@@ -127,35 +152,39 @@ static void shieldFlushEntry(Arena arena, Index i)
 }
 
 
+/* shieldCacheReset -- reset shield cache pointers */
+
+static void shieldCacheReset(Arena arena)
+{
+  AVER(arena->shDepth == 0); /* overkill: implies no segs are cached */
+  arena->shCacheI = 0;
+  arena->shCacheLimit = 0;
+}
+
+
 /* shieldCacheEntryCompare -- comparison for cache sorting */
 
+static Compare shieldAddrCompare(Addr left, Addr right)
+{
+  if (left < right)
+    return CompareLESS;
+  else if (left == right)
+    return CompareEQUAL;
+  else
+    return CompareGREATER;
+}
+
 static Compare shieldCacheEntryCompare(void *left, void *right, void *closure)
 {
   Seg segA = left, segB = right;
-  Addr baseA, baseB;
 
-  /* Making these CRITICAL had no effect on timings on LII6LL today.
-     RB 2016-03-17. */
-  AVERT(Seg, segA);
-  AVERT(Seg, segB);
+  /* These checks are not critical in a hot build, but slow down cool
+     builds quite a bit, so just check the signatures. */
+  AVER(TESTT(Seg, segA));
+  AVER(TESTT(Seg, segB));
   UNUSED(closure);
 
-  baseA = SegBase(segA);
-  baseB = SegBase(segB);
-  if (baseA < baseB)
-    return CompareLESS;
-  if (baseA > baseB)
-    return CompareGREATER;
-  AVER(baseA == baseB);
-  return CompareEQUAL;
-}
-
-
-static void shieldCacheReset(Arena arena)
-{
-  AVER(arena->shDepth == 0);
-  arena->shCacheI = 0;
-  arena->shCacheLimit = 0;
+  return shieldAddrCompare(SegBase(segA), SegBase(segB));
 }
 
 
@@ -187,7 +216,7 @@ static void shieldFlushEntries(Arena arena)
   mode = AccessSetEMPTY;
   for (i = 0; i < arena->shCacheLimit; ++i) {
     Seg seg = shieldDecache(arena, i);
-    if (!shieldSegIsSynced(seg)) {
+    if (!SegIsSynced(seg)) {
       AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
       SegSetPM(seg, SegSM(seg));
       if (SegSM(seg) != mode || SegBase(seg) != limit) {
@@ -222,10 +251,9 @@ static void shieldCache(Arena arena, Seg seg)
 {
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
-  /* Can't fully check seg while we're enforcing its invariants. */
-  AVER_CRITICAL(TESTT(Seg, seg));
+  SHIELD_AVERT_CRITICAL(Seg, seg);
 
-  if (shieldSegIsSynced(seg) || seg->cached)
+  if (SegIsSynced(seg) || seg->cached)
     return;
 
   if (SegIsExposed(seg)) {
@@ -304,14 +332,16 @@ static void shieldCache(Arena arena, Seg seg)
 }
 
 
+/* ShieldRaise -- declare segment should be protected from mutator
+ *
+ * Does not immediately protect the segment, unless the segment is
+ * covered and the shield cache is unavailable.
+ */
+
 void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
 {
-  /* .seg.broken: Seg's shield invariants may not be true at */
-  /* this point (this function is called to enforce them) so we */
-  /* can't check seg. Nor can we check arena as that checks the */
-  /* segs in the cache. */
-  AVER(TESTT(Arena, arena));
-  AVER(TESTT(Seg, seg));
+  SHIELD_AVERT(Arena, arena);
+  SHIELD_AVERT(Seg, seg);
 
   AVERT(AccessSet, mode);
   AVER((SegSM(seg) & mode) == AccessSetEMPTY);
@@ -330,14 +360,14 @@ void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
 void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 {
   AVERT(Arena, arena);
-  AVER(TESTT(Seg, seg));
+  SHIELD_AVERT(Seg, seg);
   AVERT(AccessSet, mode);
   AVER(BS_INTER(SegSM(seg), mode) == mode);
   
   /* synced(seg) is not changed by the following preserving
      inv.unsynced.suspended Also inv.prot.shield preserved */
   SegSetSM(seg, BS_DIFF(SegSM(seg), mode));
-  protLower(arena, seg, mode);
+  shieldProtLower(arena, seg, mode);
 
   /* Check cache and segment consistency. */
   AVERT(Arena, arena);
@@ -371,7 +401,7 @@ static void shieldDebugCheck(Arena arena)
     do {
       if (arena->shCacheLimit == 0) {
         AVER(!seg->cached);
-        AVER(shieldSegIsSynced(seg));
+        AVER(SegIsSynced(seg));
         /* You can directly set protections here to see if it makes a
            difference. */
         /* ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg)); */
@@ -475,7 +505,7 @@ void (ShieldExpose)(Arena arena, Seg seg)
     ShieldSuspend(arena);
 
   /* Ensure design.mps.shield.inv.expose.prot. */
-  protLower(arena, seg, mode);
+  shieldProtLower(arena, seg, mode);
 }
 
 
@@ -500,7 +530,7 @@ void (ShieldCover)(Arena arena, Seg seg)
 
 /* C. COPYRIGHT AND LICENSE
  *
- * Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
+ * Copyright (C) 2001-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
  * All rights reserved.  This is an open source license.  Contact
  * Ravenbrook for commercial licensing options.
  * 

From ff0b6d1379c3868fe6f34348caf356935b81aaa5 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 15:12:12 +0000
Subject: [PATCH 30/69] More documentation, tidying up, and cross-referencing.

Copied from Perforce
 Change: 190205
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c     | 72 ++++++++++++++++++++++++-------------------
 mps/design/shield.txt | 50 ++++++++++++++++++++++++++++++
 2 files changed, 90 insertions(+), 32 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index 88959cfecfe..be5c3c80e04 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -5,8 +5,9 @@
  *
  * See: idea.shield, design.mps.shield.
  *
- * IMPORTANT: This code is subtle and critical. Ensure you have read
- * and understood design.mps.shield before you touch it.
+ * IMPORTANT: HERE BE DRAGONS! This code is subtle and
+ * critical. Ensure you have read and understood design.mps.shield
+ * before you touch it.
  */
 
 #include "mpm.h"
@@ -196,7 +197,9 @@ static Compare shieldCacheEntryCompare(void *left, void *right, void *closure)
  * protection calls are extremely inefficient, but has no net gain on
  * Windows.
  *
- * base, limit and mode represent outstanding protection to be done.
+ * TODO: Could we keep extending the outstanding area over memory
+ * that's *not* in the cache but has the same protection mode?  Might
+ * require design.mps.shield.improve.noseg.
  */
 
 static void shieldFlushEntries(Arena arena)
@@ -357,6 +360,8 @@ void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
 }
 
 
+/* ShieldLower -- declare segment may be accessed by mutator */
+
 void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 {
   AVERT(Arena, arena);
@@ -364,9 +369,13 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
   AVERT(AccessSet, mode);
   AVER(BS_INTER(SegSM(seg), mode) == mode);
   
-  /* synced(seg) is not changed by the following preserving
-     inv.unsynced.suspended Also inv.prot.shield preserved */
+  /* SegIsSynced(seg) is not changed by the following preserving
+     design.mps.shield.inv.unsynced.suspended and
+     design.mps.shield.inv.prot.shield. */
   SegSetSM(seg, BS_DIFF(SegSM(seg), mode));
+  /* TODO: Do we need to promptly call shieldProtLower here?  It
+     loses the opportunity to coalesce the protection call. It would
+     violate design.mps.shield.prop.inside.access. */
   shieldProtLower(arena, seg, mode);
 
   /* Check cache and segment consistency. */
@@ -375,6 +384,8 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 }
 
 
+/* ShieldEnter -- enter the shield, allowing exposes */
+
 void (ShieldEnter)(Arena arena)
 {
   AVERT(Arena, arena);
@@ -388,6 +399,18 @@ void (ShieldEnter)(Arena arena)
 }
 
 
+/* shieldDebugCheck -- expensive consistency check
+ *
+ * While developing the shield it is very easy to make a consistency
+ * mistake that causes random corruption of the heap, usually because
+ * all the attempts to avoid protection and suspension end up failing
+ * to enforce design.mps.shield.prop.mutator.access.  In these cases,
+ * try enabling SHIELD_DEBUG and extending this code as necessary.
+ *
+ * The basic idea is to iterate over *all* segments and check
+ * consistency with the arena and shield cache.
+ */
+
 #if defined(SHIELD_DEBUG)
 static void shieldDebugCheck(Arena arena)
 {
@@ -419,14 +442,15 @@ static void shieldDebugCheck(Arena arena)
 /* ShieldFlush -- empty the shield cache
  *
  * .shield.flush: Flush empties the shield cache.  This needs to be
- * called before segments are destroyed as there may be references to
- * them in the cache.
+ * called before segments in the cache are destroyed, as there may be
+ * references to them in the cache.
  *
  * The memory for the segment may become spare, and not released back
  * to the operating system. Since we keep track of protection on
  * segments and not grains we have no way of keeping track of the
  * protection state of spare grains. We therefore flush the protection
- * to get it back into the default state (unprotected).
+ * to get it back into the default state (unprotected).  See also
+ * design.mps.shield.improv.noseg.
  */
 
 void (ShieldFlush)(Arena arena)
@@ -443,10 +467,13 @@ void (ShieldFlush)(Arena arena)
 }
 
 
+/* ShieldLeave -- leave the shield, protect segs from mutator */
+
 void (ShieldLeave)(Arena arena)
 {
   AVERT(Arena, arena);
   AVER(arena->insideShield);
+  AVER(arena->shDepth == 0); /* no pending covers */
 
   ShieldFlush(arena);
 
@@ -464,29 +491,8 @@ void (ShieldLeave)(Arena arena)
 
 /* ShieldExpose -- allow the MPS access to a segment while denying the mutator
  *
- * The MPS currently does not collect concurrently, however the only thing
- * that makes it not-concurrent is a critical point in the Shield
- * abstraction where the MPS seeks to gain privileged access to memory
- * (usually in order to scan it for GC). The critical point is where
- * ShieldExpose in shield.c has to call ShieldSuspend to preserve the
- * shield invariants. This is the only point in the MPS that prevents
- * concurrency, and the rest of the MPS is designed to support it.
- *
- * The restriction could be removed if either:
- * 
- *  * the MPS could use a different set of protections to the mutator
- *   program
- * 
- *  * the mutator program uses a software barrier
- * 
- * The first one is tricky, and the second one just hasn't come up in any
- * implementation we've been asked to make yet. Given a VM, it could
- * happen, and the MPS would be concurrent.
- * 
- * So, I believe there's nothing fundamentally non-concurrent about the
- * MPS design. It's kind of waiting to happen.
- *
- * (Originally written at <http://news.ycombinator.com/item?id=4524036>.)
+ * The first expose of a shielded segment suspends the mutator to
+ * ensure the MPS has exclusive access.
  */
 
 void (ShieldExpose)(Arena arena, Seg seg)
@@ -501,10 +507,12 @@ void (ShieldExpose)(Arena arena, Seg seg)
   ++arena->shDepth;
   AVER_CRITICAL(arena->shDepth > 0); /* overflow */
   
-  if (BS_INTER(SegPM(seg), mode))
+  if (BS_INTER(SegPM(seg), mode) != AccessSetEMPTY)
     ShieldSuspend(arena);
 
   /* Ensure design.mps.shield.inv.expose.prot. */
+  /* TODO: Mass exposure -- see
+     design.mps.shield.improv.mass-expose. */
   shieldProtLower(arena, seg, mode);
 }
 
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index c3369750789..57c2e309ae0 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -145,6 +145,9 @@ protection do not match.  This cache is flushed on leaving the shield.
 Definitions
 ...........
 
+.def.exposed: A seg is exposed if the prot mode is a subset of the
+shield mode, and covered otherwise.
+
 .def.synced: A seg is synced if the prot and shield modes are the
 same, and unsynced otherwise.
 
@@ -239,6 +242,10 @@ _`.ideas`: There never was an initial design document, but
 Improvement Ideas
 -----------------
 
+
+Mass exposure
+.............
+
 .improv.mass-expose: If protection calls have a high overhead it might
 be good to pre-emptively unprotect large ranges of memory when we
 expose one segment.  With the current design this would mean
@@ -247,6 +254,46 @@ The collector should take advantage of this by preferentially scanning
 exposed segments during a pause.
 
 
+Segment independence
+....................
+
+.improve.noseg: The shield is implemented in terms of segments, using
+fields in the segment structure to represent its state. This forces us
+to (for example) flush the shield cache when deleting a segment. The
+shield could keep track of protection and shielding independently,
+possibly allowing greater coalescing and more efficient and flexible
+use of system calls (see .improve.mass-expose).
+
+
+Concurrent collection
+.....................
+
+.improv.concurrent: The MPS currently does not collect concurrently,
+however the only thing that makes it not-concurrent is a critical
+point in the Shield abstraction where the MPS seeks to gain privileged
+access to memory (usually in order to scan it for GC). The critical
+point is where ShieldExpose in shield.c has to call ShieldSuspend to
+preserve the shield invariants. This is the only point in the MPS that
+prevents concurrency, and the rest of the MPS is designed to support
+it.
+
+The restriction could be removed if either:
+
+ * the MPS could use a different set of protections to the mutator
+   program
+
+ * the mutator program uses a software barrier
+
+The first one is tricky, and the second one just hasn't come up in any
+implementation we've been asked to make yet. Given a VM, it could
+happen, and the MPS would be concurrent.
+
+So, I believe there's nothing fundamentally non-concurrent about the
+MPS design. It's kind of waiting to happen.
+
+(Originally written at <http://news.ycombinator.com/item?id=4524036>.)
+
+
 References
 ----------
 
@@ -275,6 +322,9 @@ Document History
 - 2016-03-17 RB_ Updated for dynamic cacheing and general code tidying
   that has removed complaints.
 
+- 2016-03-19 RB_ Updated for separate cache flag on segments, changes
+  of invariants, cross-references, and ideas for future improvement.
+
 .. _GDR: http://www.ravenbrook.com/consultants/gdr/
 
 .. _RB: http://www.ravenbrook.com/consultants/rb/

From a6f292833547dd2a0452d6ab12428b9837a3348f Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 19:40:00 +0000
Subject: [PATCH 31/69] Removing bogus todo.

Copied from Perforce
 Change: 190212
 ServerID: perforce.ravenbrook.com
---
 mps/code/trace.c | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

diff --git a/mps/code/trace.c b/mps/code/trace.c
index cc70e71c809..f86e13f5b5f 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1166,7 +1166,7 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
     AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
 
     /* Remembered set and write barrier */
-    /* Was the scan necessary?  Did the segment refer to the white set */
+    /* Was the scan necessary?  Did the segment refer to the white set? */
     if (ZoneSetInter(ScanStateUnfixedSummary(ss), white) == ZoneSetEMPTY) {
       if (seg->defer > 0)
         --seg->defer;
@@ -1176,9 +1176,6 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
     }
 
     /* Only apply the write barrier if it is not deferred. */
-    /* TODO: This discards information we collected during
-       scanning. Consider keeping the summary but changing the
-       invariant on shielding instead. */
     if (seg->defer == 0) {
       /* If we scanned every reference in the segment then we have a
          complete summary we can set. Otherwise, we just have

From fde3757bac081b1c474812c3b4ebde2b99f3a374 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 23:07:53 +0000
Subject: [PATCH 32/69] Tidying up and adding cross references to shiny new
 design document.

Copied from Perforce
 Change: 190213
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h            |  21 +++----
 mps/code/trace.c             |  29 ++++++---
 mps/design/write-barrier.txt | 114 +++++++++++++++++++++++++++++++++++
 3 files changed, 140 insertions(+), 24 deletions(-)
 create mode 100644 mps/design/write-barrier.txt

diff --git a/mps/code/config.h b/mps/code/config.h
index 3a2165cd1d9..40702f86312 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -667,11 +667,10 @@
     { 36 * 1024, 0.45 }  /* second gen, after which dynamic */ \
   }
 
+
 /* Write barrier deferral
  *
- * Defer using the write barrier for the remembered set until a number
- * of unnecessary scans have been performed on a segment.  Avoids
- * memory protection costs when scanning might be cheaper.  See job003975.
+ * See design.mps.write-barrier.deferral.
  *
  * TODO: These settings were determined by trial and error, but should
  * be based on measurement of the protection overhead on each
@@ -682,17 +681,11 @@
  * passed in the mutator rather than the number of scans.
  */
 
-/* Number of bits needed to keep the write barrier deferral count */
-#define WB_DEFER_BITS 3
-/* The number of unecessary scans performed, before raising the write
-   barrier to maintian the remembered set. */
-#define WB_DEFER_INIT 3
-/* The number of unecessary scans performed, before raising the write
-   barrier to remember the refset summary, after a necessary scan */
-#define WB_DEFER_DELAY WB_DEFER_INIT
-/* The number of unecessary scans performed, before raising the write
- * barrier to remember the refset summary, after a barrier hit */
-#define WB_DEFER_AFTER_HIT 1
+#define WB_DEFER_BITS  3  /* bitfield width for deferral count */
+#define WB_DEFER_INIT  3  /* boring scans after new segment */
+#define WB_DEFER_DELAY 3  /* boring scans after interesting scan */
+#define WB_DEFER_HIT   1  /* boring scans after barrier hit */
+
 
 #endif /* config_h */
 
diff --git a/mps/code/trace.c b/mps/code/trace.c
index f86e13f5b5f..6e48ef5684b 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1165,12 +1165,14 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
      */
     AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
 
-    /* Remembered set and write barrier */
-    /* Was the scan necessary?  Did the segment refer to the white set? */
+    /* Write barrier deferral -- see design.mps.write-barrier.deferral. */
+    /* Did the segment refer to the white set? */
     if (ZoneSetInter(ScanStateUnfixedSummary(ss), white) == ZoneSetEMPTY) {
+      /* Boring scan.  One step closer to raising the write barrier. */
       if (seg->defer > 0)
         --seg->defer;
     } else {
+      /* Interesting scan. Defer raising the write barrier. */
       if (seg->defer < WB_DEFER_DELAY)
         seg->defer = WB_DEFER_DELAY;
     }
@@ -1229,27 +1231,34 @@ static Res traceScanSeg(TraceSet ts, Rank rank, Arena arena, Seg seg)
 void TraceSegAccess(Arena arena, Seg seg, AccessSet mode)
 {
   Res res;
+  AccessSet shieldHit;
+  Bool readHit, writeHit;
 
   AVERT(Arena, arena);
   AVERT(Seg, seg);
   AVERT(AccessSet, mode);
 
+  shieldHit = BS_INTER(mode, SegSM(seg));
+  readHit = BS_INTER(shieldHit, AccessREAD) != AccessSetEMPTY;
+  writeHit = BS_INTER(shieldHit, AccessWRITE) != AccessSetEMPTY;
+
   /* If it's a read access, then the segment must be grey for a trace */
   /* which is flipped. */
-  AVER((mode & SegSM(seg) & AccessREAD) == 0
-       || TraceSetInter(SegGrey(seg), arena->flippedTraces) != TraceSetEMPTY);
+  AVER(!readHit ||
+       TraceSetInter(SegGrey(seg), arena->flippedTraces) != TraceSetEMPTY);
 
   /* If it's a write access, then the segment must have a summary that */
   /* is smaller than the mutator's summary (which is assumed to be */
   /* RefSetUNIV). */
-  AVER((mode & SegSM(seg) & AccessWRITE) == 0 || SegSummary(seg) != RefSetUNIV);
+  AVER(!writeHit || SegSummary(seg) != RefSetUNIV);
 
   EVENT3(TraceAccess, arena, seg, mode);
 
-  if ((mode & SegSM(seg) & AccessWRITE) != 0)     /* write barrier? */
-    seg->defer = WB_DEFER_AFTER_HIT;
+  /* Write barrier deferral -- see design.mps.write-barrier.deferral. */
+  if (writeHit)
+    seg->defer = WB_DEFER_HIT;
 
-  if((mode & SegSM(seg) & AccessREAD) != 0) {   /* read barrier? */
+  if (readHit) {
     Trace trace;
     TraceId ti;
     Rank rank;
@@ -1283,11 +1292,11 @@ void TraceSegAccess(Arena arena, Seg seg, AccessSet mode)
 
   /* The write barrier handling must come after the read barrier, */
   /* because the latter may set the summary and raise the write barrier. */
-  if((mode & SegSM(seg) & AccessWRITE) != 0)      /* write barrier? */
+  if (writeHit)
     SegSetSummary(seg, RefSetUNIV);
 
   /* The segment must now be accessible. */
-  AVER((mode & SegSM(seg)) == AccessSetEMPTY);
+  AVER(BS_INTER(mode, SegSM(seg)) == AccessSetEMPTY);
 }
 
 
diff --git a/mps/design/write-barrier.txt b/mps/design/write-barrier.txt
new file mode 100644
index 00000000000..2a712ddd99c
--- /dev/null
+++ b/mps/design/write-barrier.txt
@@ -0,0 +1,114 @@
+.. mode: -*- rst -*-
+
+Write barrier
+=============
+
+:Tag: design.mps.write-barrier
+:Author: Richard Brooksby
+:Date: 2016-03-18
+:Status: incomplete design
+:Revision: $Id$
+:Copyright: See `Copyright and License`_.
+:Index terms: pair: write barrier; design
+
+
+Introduction
+------------
+
+.intro: This document explains the design of the write barrer of the
+Memory Pool System (MPS).
+
+.readership: This document is intended for developers of the MPS.
+
+
+Overview
+--------
+
+.overview: The MPS uses a combination of hardware memory protection
+and BIBOP techniques to maintain an approximate remembered set.  The
+remembered set keeps track of areas of memory that refer to each
+other, so that the MPS can avoid scanning areas that are irrelevant
+during a garbage collection.  The MPS write barrier is implemented by
+a one-word "summary" of the zones referenced by a segment.  That
+summary can be compared with the "white set" of a trace by a simple
+logical AND operation.
+
+[At this point I was interrupted by a man from Porlock.]
+
+
+Write barrier deferral
+----------------------
+
+.deferral: The overheads hardware barriers varies widely between
+operating systems.  On Windows it is very cheap to change memory
+protection and to handle protecion faults.  On OS X it is very
+expensive.  The balance between barriers and scanning work is
+different.  There is no point in spending 1000 CPU units raising a
+write barrier to avoid 10 CPU units of scanning cost.
+
+The MPS balances these costs with write barrier deferral.  The write
+barrier is not immediately raised when a segment is scanned.  Instead,
+we store a deferral count with the segment.  Each time the segment is
+"boring" scanned the count is decremented.  A boring scan is one that
+found no interesting references (to white objects).  The write barrier
+is raised only when the count reaches zero.  The count is reset after
+three events:
+
+1. segment creation (``WB_DEFER_INIT``)
+
+2. an interesting scan (``WB_DEFER_DELAY``)
+
+3. a barrier hit (``WB_DEFER_HIT``)
+
+See also job003975.
+
+
+Document History
+----------------
+
+- 2016-03-19  RB_  Created.
+
+.. _RB: http://www.ravenbrook.com/consultants/rb/
+
+
+Copyright and License
+---------------------
+
+Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
+<http://www.ravenbrook.com/>. This is an open source license. Contact
+Ravenbrook for commercial licensing options.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+#. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+#. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+#. Redistributions in any form must be accompanied by information on how
+   to obtain complete source code for this software and any
+   accompanying software that uses this software.  The source code must
+   either be included in the distribution or be available for no more than
+   the cost of distribution plus a nominal fee, and must be freely
+   redistributable under reasonable conditions.  For an executable file,
+   complete source code means the source code for all modules it contains.
+   It does not include source code for modules or files that typically
+   accompany the major components of the operating system on which the
+   executable file runs.
+
+**This software is provided by the copyright holders and contributors
+"as is" and any express or implied warranties, including, but not
+limited to, the implied warranties of merchantability, fitness for a
+particular purpose, or non-infringement, are disclaimed.  In no event
+shall the copyright holders and contributors be liable for any direct,
+indirect, incidental, special, exemplary, or consequential damages
+(including, but not limited to, procurement of substitute goods or
+services; loss of use, data, or profits; or business interruption)
+however caused and on any theory of liability, whether in contract,
+strict liability, or tort (including negligence or otherwise) arising in
+any way out of the use of this software, even if advised of the
+possibility of such damage.**

From 2469f09e6e0e66c8082b1e3b257be495db8ec7c6 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 23:31:00 +0000
Subject: [PATCH 33/69] Improving design document with references and
 separating ideas from current implementation.

Copied from Perforce
 Change: 190214
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h            |  2 +-
 mps/design/write-barrier.txt | 38 ++++++++++++++++++++++++++++--------
 2 files changed, 31 insertions(+), 9 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index 40702f86312..b7de3a7a227 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -675,7 +675,7 @@
  * TODO: These settings were determined by trial and error, but should
  * be based on measurement of the protection overhead on each
  * platform.  We know it's extremely different between OS X and
- * Windows, for example.
+ * Windows, for example.  See design.mps.write-barrier.improv.by-os.
  *
  * TODO: Consider basing the count on the amount of time that has
  * passed in the mutator rather than the number of scans.
diff --git a/mps/design/write-barrier.txt b/mps/design/write-barrier.txt
index 2a712ddd99c..affdaa49c5d 100644
--- a/mps/design/write-barrier.txt
+++ b/mps/design/write-barrier.txt
@@ -39,12 +39,9 @@ logical AND operation.
 Write barrier deferral
 ----------------------
 
-.deferral: The overheads hardware barriers varies widely between
-operating systems.  On Windows it is very cheap to change memory
-protection and to handle protecion faults.  On OS X it is very
-expensive.  The balance between barriers and scanning work is
-different.  There is no point in spending 1000 CPU units raising a
-write barrier to avoid 10 CPU units of scanning cost.
+.deferral: Both scanning and the write barrier cost CPU time, and
+these must be balanced.  There is no point spending 1000 CPU units
+raising a write barrier to avoid 10 CPU units of scanning cost.
 
 The MPS balances these costs with write barrier deferral.  The write
 barrier is not immediately raised when a segment is scanned.  Instead,
@@ -60,13 +57,38 @@ three events:
 
 3. a barrier hit (``WB_DEFER_HIT``)
 
-See also job003975.
+
+Improvements
+------------
+
+.improv.by-os: The overheads hardware barriers varies widely between
+operating systems.  On Windows it is very cheap to change memory
+protection and to handle protecion faults.  On OS X it is very
+expensive.  The balance between barriers and scanning work is
+different.  We should measure the relative costs and tune the deferral
+for each separately.
+
+.improv.balance: Hardware costs of write barriers vary by OS, but
+scanning costs vary depending on many factors including client code.
+The MPS could dynamically measure these costs, perhaps using fast
+cycle counters such as RDTSC, and use this to dynamically balance the
+write barrier deferral.
 
 
+References
+----------
+
+.. [job003975] "Poor performance due to imbalance between protection
+               and scanning costs"; Richard Brooksby; Ravenbrook
+               Limited; 2016-03-11;
+               <http://www.ravenbrook.com/project/mps/issue/job003975>.
+
+               
 Document History
 ----------------
 
-- 2016-03-19  RB_  Created.
+- 2016-03-19 RB_ Created during preparation of
+  branch/2016-03-13/defer-write-barrier for [job003975]_.
 
 .. _RB: http://www.ravenbrook.com/consultants/rb/
 

From e09dbaab0fb182fd570d6da4238b4108ba2cad27 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 20 Mar 2016 00:32:43 +0000
Subject: [PATCH 34/69] Promoting shield to first class structure.

Copied from Perforce
 Change: 190219
 ServerID: perforce.ravenbrook.com
---
 mps/code/global.c   |  60 +---------
 mps/code/mpm.h      |   4 +
 mps/code/mpmst.h    |  33 ++++--
 mps/code/mpmtypes.h |   1 +
 mps/code/poolmrg.c  |   2 +-
 mps/code/shield.c   | 270 +++++++++++++++++++++++++++++++-------------
 6 files changed, 226 insertions(+), 144 deletions(-)

diff --git a/mps/code/global.c b/mps/code/global.c
index ce8885daf04..111404d03f8 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -154,39 +154,8 @@ Bool GlobalsCheck(Globals arenaGlobals)
   CHECKD_NOSIG(Ring, &arena->threadRing);
   CHECKD_NOSIG(Ring, &arena->deadRing);
 
-  CHECKL(BoolCheck(arena->insideShield));
-  CHECKL(arena->shCache == NULL || arena->shCacheLength > 0);
-  CHECKL(arena->shCacheLimit <= arena->shCacheLength);
-  CHECKL(arena->shCacheI <= arena->shCacheLimit);
-  CHECKL(BoolCheck(arena->suspended));
+  CHECKD_NOSIG(Shield, &arena->shieldStruct); /* FIXME: Sig */
 
-  /* The mutator is not suspended while outside the shield
-     (design.mps.shield.inv.outside.running). */
-  CHECKL(arena->insideShield || !arena->suspended);
-
-  /* If any segment is not synced, the mutator is suspended
-     (design.mps.shield.inv.unsynced.suspended). */
-  CHECKL(arena->shDepth == 0 || arena->suspended);
-
-  /* The total depth is zero while outside the shield
-     (design.mps.shield.inv.outside.depth). */
-  CHECKL(arena->insideShield || arena->shDepth == 0);
-
-  /* This is too expensive to check all the time since we have an
-     expanding shield cache that often has 16K elements instead of
-     16. */
-#if defined(AVER_AND_CHECK_ALL)
-  {
-    Count depth = 0;
-    for (i = 0; i < arena->shCacheLimit; ++i) {
-      Seg seg = arena->shCache[i];
-      CHECKD(Seg, seg);
-      depth += SegDepth(seg);
-    }
-    CHECKL(depth <= arena->shDepth);
-  }
-#endif
-  
   CHECKL(TraceSetCheck(arena->busyTraces));
   CHECKL(TraceSetCheck(arena->flippedTraces));
   CHECKL(TraceSetSuper(arena->busyTraces, arena->flippedTraces));
@@ -311,13 +280,7 @@ Res GlobalsInit(Globals arenaGlobals)
   arena->tracedWork = 0.0;
   arena->tracedTime = 0.0;
   arena->lastWorldCollect = ClockNow();
-  arena->insideShield = FALSE;          /* <code/shield.c> */
-  arena->shCache = NULL;
-  arena->shCacheLength = 0;
-  arena->shCacheI = (Size)0;
-  arena->shCacheLimit = (Size)0;
-  arena->shDepth = (Size)0;
-  arena->suspended = FALSE;
+  ShieldInit(&arena->shieldStruct);
 
   for (ti = 0; ti < TraceLIMIT; ++ti) {
     /* <design/arena/#trace.invalid> */
@@ -455,14 +418,7 @@ void GlobalsPrepareToDestroy(Globals arenaGlobals)
 
   arena = GlobalsArena(arenaGlobals);
 
-  /* Delete the shield cache, if it exists. */
-  if (arena->shCacheLength != 0) {
-    AVER(arena->shCache != NULL);
-    ControlFree(arena, arena->shCache,
-                arena->shCacheLength * sizeof arena->shCache[0]);
-    arena->shCache = NULL;
-    arena->shCacheLength = 0;
-  }
+  ShieldFinish(&arena->shieldStruct, arena);
 
   arenaDenounce(arena);
 
@@ -1027,7 +983,6 @@ Res GlobalsDescribe(Globals arenaGlobals, mps_lib_FILE *stream, Count depth)
                "rootSerial $U\n", (WriteFU)arenaGlobals->rootSerial,
                "formatSerial $U\n", (WriteFU)arena->formatSerial,
                "threadSerial $U\n", (WriteFU)arena->threadSerial,
-               arena->insideShield ? "inside" : "outside", " shield\n",
                "busyTraces    $B\n", (WriteFB)arena->busyTraces,
                "flippedTraces $B\n", (WriteFB)arena->flippedTraces,
                "epoch $U\n", (WriteFU)arena->epoch,
@@ -1046,14 +1001,7 @@ Res GlobalsDescribe(Globals arenaGlobals, mps_lib_FILE *stream, Count depth)
       return res;
   }
 
-  res = WriteF(stream, depth,
-               "} history\n",
-               "suspended $S\n", WriteFYesNo(arena->suspended),
-               "shDepth $U\n", (WriteFU)arena->shDepth,
-               "shCacheI $U\n", (WriteFU)arena->shCacheI,
-               "shCacheLength $U\n", (WriteFU)arena->shCacheLength,
-               /* @@@@ should SegDescribe the cached segs? */
-               NULL);
+  res = ShieldDescribe(&arena->shieldStruct, stream, depth);
   if (res != ResOK)
     return res;
 
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index 96f28ffc840..21e9e82182a 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -907,6 +907,10 @@ extern ZoneSet ZoneSetBlacklist(Arena arena);
 
 /* Shield Interface -- see <code/shield.c> */
 
+extern void ShieldInit(Shield shield);
+extern void ShieldFinish(Shield shield, Arena arena);
+extern Bool ShieldCheck(Shield shield);
+extern Res ShieldDescribe(Shield shield, mps_lib_FILE *stream, Count depth);
 extern void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode);
 extern void (ShieldLower)(Arena arena, Seg seg, AccessSet mode);
 extern void (ShieldEnter)(Arena arena);
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 1ee48063c8d..29ad117bbcd 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -677,9 +677,29 @@ typedef struct FreelistStruct {
 } FreelistStruct;
 
 
+/* ShieldStruct -- per-arena part of the shield
+ *
+ * See design.mps.shield, impl.c.shield.
+ */
+
+#define ShieldSig      ((Sig)0x519581E1) /* SIGnature SHEILd */
+
+typedef struct ShieldStruct {
+  Sig sig;
+  Bool inside;       /* TRUE if and only if inside shield */
+  Seg *cache;        /* Cache of unsynced segs */
+  Count length;      /* number of elements in shield cache */
+  Index i;           /* index into cache */
+  Index limit;       /* High water mark for cache usage */
+  Count depth;       /* sum of depths of all segs */
+  Bool suspended;    /* TRUE iff mutator suspended */
+} ShieldStruct;
+
+
 /* ArenaStruct -- generic arena
  *
- * See <code/arena.c>.  */
+ * See <code/arena.c>.
+ */
 
 #define ArenaSig        ((Sig)0x519A6E4A) /* SIGnature ARENA */
 
@@ -737,16 +757,9 @@ typedef struct mps_arena_s {
   RingStruct threadRing;        /* ring of attached threads */
   RingStruct deadRing;          /* ring of dead threads */
   Serial threadSerial;          /* serial of next thread */
- 
-  /* shield fields (<code/shield.c>) */
-  Bool insideShield;             /* TRUE if and only if inside shield */
-  Seg *shCache;                  /* Cache of unsynced segs */
-  Count shCacheLength;
-  Size shCacheI;                 /* index into cache */
-  Size shCacheLimit;             /* High water mark for cache usage */
-  Size shDepth;                  /* sum of depths of all segs */
-  Bool suspended;                /* TRUE iff mutator suspended */
 
+  ShieldStruct shieldStruct;
+  
   /* trace fields (<code/trace.c>) */
   TraceSet busyTraces;          /* set of running traces */
   TraceSet flippedTraces;       /* set of running and flipped traces */
diff --git a/mps/code/mpmtypes.h b/mps/code/mpmtypes.h
index 2e0837940a2..f001038bc9f 100644
--- a/mps/code/mpmtypes.h
+++ b/mps/code/mpmtypes.h
@@ -112,6 +112,7 @@ typedef struct RangeStruct *Range;      /* <design/range/> */
 typedef struct LandStruct *Land;        /* <design/land/> */
 typedef struct LandClassStruct *LandClass; /* <design/land/> */
 typedef unsigned FindDelete;            /* <design/land/> */
+typedef struct ShieldStruct *Shield; /* design.mps.shield */
 
 
 /* Arena*Method -- see <code/mpmst.h#ArenaClassStruct> */
diff --git a/mps/code/poolmrg.c b/mps/code/poolmrg.c
index 92b1819fa68..554ec2a7319 100644
--- a/mps/code/poolmrg.c
+++ b/mps/code/poolmrg.c
@@ -821,7 +821,7 @@ static Res MRGDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
   if (res != ResOK)
     return res;
   RING_FOR(node, &mrg->entryRing, nextNode) {
-    Bool outsideShield = !arena->insideShield;
+    Bool outsideShield = !arena->shieldStruct.inside;
     refPart = MRGRefPartOfLink(linkOfRing(node), arena);
     if (outsideShield) {
       ShieldEnter(arena);
diff --git a/mps/code/shield.c b/mps/code/shield.c
index be5c3c80e04..8ba806a701a 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -15,6 +15,95 @@
 SRCID(shield, "$Id$");
 
 
+void ShieldInit(Shield shield)
+{
+  shield->inside = FALSE;
+  shield->cache = NULL;
+  shield->length = 0;
+  shield->i = 0;
+  shield->limit = 0;
+  shield->depth = 0;
+  shield->suspended = FALSE;
+  shield->sig = ShieldSig;
+}
+
+
+void ShieldFinish(Shield shield, Arena arena)
+{
+  shield->sig = SigInvalid;
+  /* Delete the shield cache, if it exists. */
+  if (shield->length != 0) {
+    AVER(shield->cache != NULL);
+    ControlFree(arena, shield->cache,
+                shield->length * sizeof shield->cache[0]);
+    shield->cache = NULL;
+    shield->length = 0;
+  }
+}
+
+
+Bool ShieldCheck(Shield shield)
+{
+  CHECKS(Shield, shield);
+  CHECKL(BoolCheck(shield->inside));
+  CHECKL(shield->cache == NULL || shield->length > 0);
+  CHECKL(shield->limit <= shield->length);
+  CHECKL(shield->i <= shield->limit);
+  CHECKL(BoolCheck(shield->suspended));
+
+  /* The mutator is not suspended while outside the shield
+     (design.mps.shield.inv.outside.running). */
+  CHECKL(shield->inside || !shield->suspended);
+
+  /* If any segment is not synced, the mutator is suspended
+     (design.mps.shield.inv.unsynced.suspended). */
+  CHECKL(shield->depth == 0 || shield->suspended);
+
+  /* The total depth is zero while outside the shield
+     (design.mps.shield.inv.outside.depth). */
+  CHECKL(shield->inside || shield->depth == 0);
+
+  /* This is too expensive to check all the time since we have an
+     expanding shield cache that often has 16K elements instead of
+     16. */
+#if defined(AVER_AND_CHECK_ALL)
+  {
+    Count depth = 0;
+    Index i;
+    for (i = 0; i < shield->limit; ++i) {
+      Seg seg = shield->cache[i];
+      CHECKD(Seg, seg);
+      depth += SegDepth(seg);
+    }
+    CHECKL(depth <= shield->depth);
+  }
+#endif
+
+  return TRUE;
+}
+
+
+Res ShieldDescribe(Shield shield, mps_lib_FILE *stream, Count depth)
+{
+  Res res;
+  
+  res = WriteF(stream, depth,
+               shield->inside ? "inside" : "outside", " shield\n",
+               "suspended $S\n", WriteFYesNo(shield->suspended),
+               "shield depth $U\n", (WriteFU)shield->depth,
+               "shield i $U\n", (WriteFU)shield->i,
+               "shield length $U\n", (WriteFU)shield->length,
+               NULL);
+  if (res != ResOK)
+    return res;
+
+  return ResOK;
+}
+
+
+#define ArenaShield(arena) (&(arena)->shieldStruct)
+
+
 /* SHIELD_AVER -- transgressive argument checking
  *
  * .trans.check: A number of shield functions cannot do normal
@@ -57,9 +146,9 @@ static Bool SegIsExposed(Seg seg)
  * See design.mps.shield.inv.prot.shield.
  */
 
-static void shieldSync(Arena arena, Seg seg)
+static void shieldSync(Shield shield, Seg seg)
 {
-  AVERT(Arena, arena);
+  UNUSED(shield);
   SHIELD_AVERT_CRITICAL(Seg, seg);
 
   if (!SegIsSynced(seg)) {
@@ -81,12 +170,15 @@ static void shieldSync(Arena arena, Seg seg)
 
 void (ShieldSuspend)(Arena arena)
 {
+  Shield shield;
+  
   AVERT(Arena, arena);
-  AVER(arena->insideShield);
+  shield = ArenaShield(arena);
+  AVER(shield->inside);
 
-  if (!arena->suspended) {
+  if (!shield->suspended) {
     ThreadRingSuspend(ArenaThreadRing(arena), ArenaDeadRing(arena));
-    arena->suspended = TRUE;
+    shield->suspended = TRUE;
   }
 }
 
@@ -99,9 +191,13 @@ void (ShieldSuspend)(Arena arena)
 
 void (ShieldResume)(Arena arena)
 {
+  Shield shield;
+  
   AVERT(Arena, arena);
-  AVER(arena->insideShield);
-  AVER(arena->suspended);
+  shield = ArenaShield(arena);
+  AVER(shield->inside);
+  AVER(shield->suspended);
+
   /* It is only correct to actually resume the mutator here if shDepth is 0 */
   /* TODO: Consider actually doing that. */
 }
@@ -112,11 +208,9 @@ void (ShieldResume)(Arena arena)
  * This ensures actual prot mode does not include mode.
  */
 
-static void shieldProtLower(Arena arena, Seg seg, AccessSet mode)
+static void shieldProtLower(Seg seg, AccessSet mode)
 {
   /* <design/trace/#fix.noaver> */
-  AVERT_CRITICAL(Arena, arena);
-  UNUSED(arena);
   SHIELD_AVERT_CRITICAL(Seg, seg);
   AVERT_CRITICAL(AccessSet, mode);
 
@@ -129,14 +223,14 @@ static void shieldProtLower(Arena arena, Seg seg, AccessSet mode)
 
 /* shieldDecache -- remove a segment from the shield cache */
 
-static Seg shieldDecache(Arena arena, Index i)
+static Seg shieldDecache(Shield shield, Index i)
 {
   Seg seg;
-  AVER(i < arena->shCacheLimit);
-  seg = arena->shCache[i];
+  AVER(i < shield->limit);
+  seg = shield->cache[i];
   AVERT(Seg, seg);
   AVER(seg->cached);
-  arena->shCache[i] = NULL;
+  shield->cache[i] = NULL;
   seg->cached = FALSE;
   return seg;
 }
@@ -144,22 +238,22 @@ static Seg shieldDecache(Arena arena, Index i)
 
 /* shieldFlushEntry -- flush a single entry from the cache */
 
-static void shieldFlushEntry(Arena arena, Index i)
+static void shieldFlushEntry(Shield shield, Index i)
 {
-  Seg seg = shieldDecache(arena, i);
+  Seg seg = shieldDecache(shield, i);
 
   if (!SegIsExposed(seg))
-    shieldSync(arena, seg);
+    shieldSync(shield, seg);
 }
 
 
 /* shieldCacheReset -- reset shield cache pointers */
 
-static void shieldCacheReset(Arena arena)
+static void shieldCacheReset(Shield shield)
 {
-  AVER(arena->shDepth == 0); /* overkill: implies no segs are cached */
-  arena->shCacheI = 0;
-  arena->shCacheLimit = 0;
+  AVER(shield->depth == 0); /* overkill: implies no segs are cached */
+  shield->i = 0;
+  shield->limit = 0;
 }
 
 
@@ -202,23 +296,23 @@ static Compare shieldCacheEntryCompare(void *left, void *right, void *closure)
  * require design.mps.shield.improve.noseg.
  */
 
-static void shieldFlushEntries(Arena arena)
+static void shieldFlushEntries(Shield shield)
 {
   Addr base = NULL, limit = NULL;
   AccessSet mode;
   Index i;
 
-  if (arena->shCacheLength == 0) {
-    AVER(arena->shCache == NULL);
+  if (shield->length == 0) {
+    AVER(shield->cache == NULL);
     return;
   }
 
-  QuickSort((void *)arena->shCache, arena->shCacheLimit,
+  QuickSort((void *)shield->cache, shield->limit,
             shieldCacheEntryCompare, UNUSED_POINTER);
 
   mode = AccessSetEMPTY;
-  for (i = 0; i < arena->shCacheLimit; ++i) {
-    Seg seg = shieldDecache(arena, i);
+  for (i = 0; i < shield->limit; ++i) {
+    Seg seg = shieldDecache(shield, i);
     if (!SegIsSynced(seg)) {
       AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
       SegSetPM(seg, SegSM(seg));
@@ -240,7 +334,7 @@ static void shieldFlushEntries(Arena arena)
     ProtSet(base, limit, mode);
   }
 
-  shieldCacheReset(arena);
+  shieldCacheReset(shield);
 }
 
 
@@ -252,8 +346,11 @@ static void shieldFlushEntries(Arena arena)
 
 static void shieldCache(Arena arena, Seg seg)
 {
+  Shield shield;
+  
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
+  shield = ArenaShield(arena);
   SHIELD_AVERT_CRITICAL(Seg, seg);
 
   if (SegIsSynced(seg) || seg->cached)
@@ -271,31 +368,31 @@ static void shieldCache(Arena arena, Seg seg)
   /* Allocate shield cache if necessary. */
   /* TODO: This will try to extend the cache on every attempt, even
      if it failed last time. That might be slow. */
-  if (arena->shCacheI >= arena->shCacheLength) {
+  if (shield->i >= shield->length) {
     void *p;
     Res res;
     Count length;
 
-    AVER(arena->shCacheI == arena->shCacheLength);
+    AVER(shield->i == shield->length);
 
-    if (arena->shCacheLength == 0)
+    if (shield->length == 0)
       length = ShieldCacheLENGTH;
     else
-      length = arena->shCacheLength * 2;
+      length = shield->length * 2;
     
-    res = ControlAlloc(&p, arena, length * sizeof arena->shCache[0]);
+    res = ControlAlloc(&p, arena, length * sizeof shield->cache[0]);
     if (res != ResOK) {
       AVER(ResIsAllocFailure(res));
       /* Carry on with the existing cache. */
     } else {
-      if (arena->shCacheLength > 0) {
-        Size oldSize = arena->shCacheLength * sizeof arena->shCache[0];
-        AVER(arena->shCache != NULL);
-        mps_lib_memcpy(p, arena->shCache, oldSize);
-        ControlFree(arena, arena->shCache, oldSize);
+      if (shield->length > 0) {
+        Size oldSize = shield->length * sizeof shield->cache[0];
+        AVER(shield->cache != NULL);
+        mps_lib_memcpy(p, shield->cache, oldSize);
+        ControlFree(arena, shield->cache, oldSize);
       }
-      arena->shCache = p;
-      arena->shCacheLength = length;
+      shield->cache = p;
+      shield->length = length;
     }
   }
 
@@ -303,35 +400,35 @@ static void shieldCache(Arena arena, Seg seg)
      yet suspended and the code raises the shield on a covered
      segment, protect it now, because that's probably better than
      suspending the mutator. */
-  if (arena->shCacheLength == 0 || !arena->suspended) {
-    shieldSync(arena, seg);
+  if (shield->length == 0 || !shield->suspended) {
+    shieldSync(shield, seg);
     return;
   }
 
-  AVER_CRITICAL(arena->shCacheLimit <= arena->shCacheLength);
-  AVER_CRITICAL(arena->shCacheI <= arena->shCacheLimit);
+  AVER_CRITICAL(shield->limit <= shield->length);
+  AVER_CRITICAL(shield->i <= shield->limit);
 
-  if (arena->shCacheI >= arena->shCacheLength)
-    arena->shCacheI = 0;
-  AVER_CRITICAL(arena->shCacheI < arena->shCacheLength);
+  if (shield->i >= shield->length)
+    shield->i = 0;
+  AVER_CRITICAL(shield->i < shield->length);
 
-  AVER_CRITICAL(arena->shCacheLength > 0);
+  AVER_CRITICAL(shield->length > 0);
 
   /* If the limit is less than the length, then the cache array has
      yet to be filled, and shCacheI is an uninitialized entry.
      Otherwise it's the tail end from last time around, and needs to
      be flushed. */
-  if (arena->shCacheLimit >= arena->shCacheLength) {
-    AVER_CRITICAL(arena->shCacheLimit == arena->shCacheLength);
-    shieldFlushEntry(arena, arena->shCacheI);
+  if (shield->limit >= shield->length) {
+    AVER_CRITICAL(shield->limit == shield->length);
+    shieldFlushEntry(shield, shield->i);
   }
 
-  arena->shCache[arena->shCacheI] = seg;
-  ++arena->shCacheI;
+  shield->cache[shield->i] = seg;
+  ++shield->i;
   seg->cached = TRUE;
 
-  if (arena->shCacheI >= arena->shCacheLimit)
-    arena->shCacheLimit = arena->shCacheI;
+  if (shield->i >= shield->limit)
+    shield->limit = shield->i;
 }
 
 
@@ -343,6 +440,7 @@ static void shieldCache(Arena arena, Seg seg)
 
 void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
 {
+  
   SHIELD_AVERT(Arena, arena);
   SHIELD_AVERT(Seg, seg);
 
@@ -376,7 +474,7 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
   /* TODO: Do we need to promptly call shieldProtLower here?  It
      loses the opportunity to coalesce the protection call. It would
      violate design.mps.shield.prop.inside.access. */
-  shieldProtLower(arena, seg, mode);
+  shieldProtLower(seg, mode);
 
   /* Check cache and segment consistency. */
   AVERT(Arena, arena);
@@ -388,14 +486,17 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 
 void (ShieldEnter)(Arena arena)
 {
+  Shield shield;
+  
   AVERT(Arena, arena);
-  AVER(!arena->insideShield);
-  AVER(arena->shDepth == 0);
-  AVER(!arena->suspended);
+  shield = ArenaShield(arena);
+  AVER(!shield->inside);
+  AVER(shield->depth == 0);
+  AVER(!shield->suspended);
 
-  shieldCacheReset(arena);
+  shieldCacheReset(shield);
 
-  arena->insideShield = TRUE;
+  shield->inside = TRUE;
 }
 
 
@@ -414,15 +515,17 @@ void (ShieldEnter)(Arena arena)
 #if defined(SHIELD_DEBUG)
 static void shieldDebugCheck(Arena arena)
 {
+  Shield shield;
   Seg seg;
   Count cached = 0;
 
   AVERT(Arena, arena);
-  AVER(arena->insideShield || arena->shCacheLimit == 0);
+  shield = ShieldArena(arena);
+  AVER(shield->inside || shield->limit == 0);
 
   if (SegFirst(&seg, arena))
     do {
-      if (arena->shCacheLimit == 0) {
+      if (shield->limit == 0) {
         AVER(!seg->cached);
         AVER(SegIsSynced(seg));
         /* You can directly set protections here to see if it makes a
@@ -434,7 +537,7 @@ static void shieldDebugCheck(Arena arena)
       }
     } while(SegNext(&seg, arena, seg));
 
-  AVER(cached == arena->shCacheLimit);
+  AVER(cached == shield->limit);
 }
 #endif
 
@@ -455,12 +558,16 @@ static void shieldDebugCheck(Arena arena)
 
 void (ShieldFlush)(Arena arena)
 {
+  Shield shield;
+  
+  AVERT(Arena, arena);
+  shield = ArenaShield(arena);
 #ifdef SHIELD_DEBUG
   shieldDebugCheck(arena);
 #endif
-  shieldFlushEntries(arena);
+  shieldFlushEntries(shield);
   /* Cache is empty so .inv.outside.depth holds */
-  AVER(arena->shDepth == 0);
+  AVER(shield->depth == 0);
 #ifdef SHIELD_DEBUG
   shieldDebugCheck(arena);
 #endif
@@ -471,20 +578,23 @@ void (ShieldFlush)(Arena arena)
 
 void (ShieldLeave)(Arena arena)
 {
+  Shield shield;
+  
   AVERT(Arena, arena);
-  AVER(arena->insideShield);
-  AVER(arena->shDepth == 0); /* no pending covers */
+  shield = ArenaShield(arena);
+  AVER(shield->inside);
+  AVER(shield->depth == 0); /* no pending covers */
 
   ShieldFlush(arena);
 
   /* Ensuring the mutator is running at this point guarantees
      .inv.outside.running */
-  if (arena->suspended) {
+  if (shield->suspended) {
     ThreadRingResume(ArenaThreadRing(arena), ArenaDeadRing(arena));
-    arena->suspended = FALSE;
+    shield->suspended = FALSE;
   }
 
-  arena->insideShield = FALSE;
+  shield->inside = FALSE;
 }
 
 
@@ -497,15 +607,18 @@ void (ShieldLeave)(Arena arena)
 
 void (ShieldExpose)(Arena arena, Seg seg)
 {
+  Shield shield;
   AccessSet mode = AccessREAD | AccessWRITE;
+
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
-  AVER_CRITICAL(arena->insideShield);
+  shield = ArenaShield(arena);
+  AVER_CRITICAL(shield->inside);
 
   SegSetDepth(seg, SegDepth(seg) + 1);
   AVER_CRITICAL(SegDepth(seg) > 0); /* overflow */
-  ++arena->shDepth;
-  AVER_CRITICAL(arena->shDepth > 0); /* overflow */
+  ++shield->depth;
+  AVER_CRITICAL(shield->depth > 0); /* overflow */
   
   if (BS_INTER(SegPM(seg), mode) != AccessSetEMPTY)
     ShieldSuspend(arena);
@@ -513,7 +626,7 @@ void (ShieldExpose)(Arena arena, Seg seg)
   /* Ensure design.mps.shield.inv.expose.prot. */
   /* TODO: Mass exposure -- see
      design.mps.shield.improv.mass-expose. */
-  shieldProtLower(arena, seg, mode);
+  shieldProtLower(seg, mode);
 }
 
 
@@ -521,15 +634,18 @@ void (ShieldExpose)(Arena arena, Seg seg)
 
 void (ShieldCover)(Arena arena, Seg seg)
 {
+  Shield shield;
+  
   /* <design/trace/#fix.noaver> */
   AVERT_CRITICAL(Arena, arena);
+  shield = ArenaShield(arena);
   AVERT_CRITICAL(Seg, seg);
   AVER_CRITICAL(SegPM(seg) == AccessSetEMPTY);
  
   AVER_CRITICAL(SegDepth(seg) > 0);
   SegSetDepth(seg, SegDepth(seg) - 1);
-  AVER_CRITICAL(arena->shDepth > 0);
-  --arena->shDepth;
+  AVER_CRITICAL(shield->depth > 0);
+  --shield->depth;
 
   /* Ensure design.mps.shield.inv.unsynced.depth. */
   shieldCache(arena, seg);

From b97bd74013a16508d14d8ea251a0970e431f630a Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 20 Mar 2016 00:46:59 +0000
Subject: [PATCH 35/69] Renaming shield cache to shield queue.

Copied from Perforce
 Change: 190220
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h     |   2 +-
 mps/code/mpmst.h      |  14 ++--
 mps/code/seg.c        |  10 +--
 mps/code/shield.c     | 162 +++++++++++++++++++++---------------------
 mps/design/shield.txt |  24 +++----
 5 files changed, 106 insertions(+), 106 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index bfaaa2e6e4b..e9cb47ee27d 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -483,7 +483,7 @@
 
 /* Shield Configuration -- see <code/shield.c> */
 
-#define ShieldCacheLENGTH  512  /* initial length of shield cache */
+#define ShieldQueueLENGTH  512  /* initial length of shield queue */
 #define ShieldDepthWIDTH     4  /* log2(max nested exposes + 1) */
 
 
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 29ad117bbcd..64ddd12b202 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -254,7 +254,7 @@ typedef struct SegStruct {      /* segment structure */
   RingStruct poolRing;          /* link in list of segs in pool */
   Addr limit;                   /* limit of segment */
   unsigned depth : ShieldDepthWIDTH; /* see design.mps.shield.def.depth */
-  BOOLFIELD(cached);            /* in shield cache? */
+  BOOLFIELD(queued);            /* in shield queue? */
   AccessSet pm : AccessLIMIT;   /* protection mode, <code/shield.c> */
   AccessSet sm : AccessLIMIT;   /* shield mode, <code/shield.c> */
   TraceSet grey : TraceLIMIT;   /* traces for which seg is grey */
@@ -686,13 +686,13 @@ typedef struct FreelistStruct {
 
 typedef struct ShieldStruct {
   Sig sig;
-  Bool inside;       /* TRUE if and only if inside shield */
-  Seg *cache;        /* Cache of unsynced segs */
-  Count length;      /* number of elements in shield cache */
-  Index i;           /* index into cache */
-  Index limit;       /* High water mark for cache usage */
+  Bool inside;       /* design.mps.shield.def.inside */
+  Seg *queue;        /* queue of unsynced segs */
+  Count length;      /* number of elements in shield queue */
+  Index next;        /* next free element in shield queue */
+  Index limit;       /* high water mark for cache usage */
   Count depth;       /* sum of depths of all segs */
-  Bool suspended;    /* TRUE iff mutator suspended */
+  Bool suspended;    /* mutator suspended? */
 } ShieldStruct;
 
 
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 8f3fe37dcd7..71fee6a4a1e 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -150,7 +150,7 @@ static Res SegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
   seg->pm = AccessSetEMPTY;
   seg->sm = AccessSetEMPTY;
   seg->depth = 0;
-  seg->cached = FALSE;
+  seg->queued = FALSE;
   seg->firstTract = NULL;
 
   seg->sig = SegSig;  /* set sig now so tract checks will see it */
@@ -222,9 +222,9 @@ static void SegFinish(Seg seg)
 
   /* See <code/shield.c#shield.flush> */
   AVER(seg->depth == 0);
-  if (seg->cached)
+  if (seg->queued)
     ShieldFlush(PoolArena(SegPool(seg)));
-  AVER(seg->cached == FALSE);
+  AVER(seg->queued == FALSE);
 
   limit = SegLimit(seg);
   
@@ -716,9 +716,9 @@ Bool SegCheck(Seg seg)
      (design.mps.shield.inv.prot.shield). */
   CHECKL(BS_DIFF(seg->pm, seg->sm) == 0);
   
-  /* All unsynced segments have positive depth or are in the cache
+  /* All unsynced segments have positive depth or are in the queue
      (design.mps.shield.inv.unsynced.depth). */
-  CHECKL(seg->sm == seg->pm || seg->depth > 0 || seg->cached);
+  CHECKL(seg->sm == seg->pm || seg->depth > 0 || seg->queued);
   
   CHECKL(RankSetCheck(seg->rankSet));
   if (seg->rankSet == RankSetEMPTY) {
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 8ba806a701a..ecabcf96dc3 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -18,9 +18,9 @@ SRCID(shield, "$Id$");
 void ShieldInit(Shield shield)
 {
   shield->inside = FALSE;
-  shield->cache = NULL;
+  shield->queue = NULL;
   shield->length = 0;
-  shield->i = 0;
+  shield->next = 0;
   shield->limit = 0;
   shield->depth = 0;
   shield->suspended = FALSE;
@@ -31,12 +31,12 @@ void ShieldInit(Shield shield)
 void ShieldFinish(Shield shield, Arena arena)
 {
   shield->sig = SigInvalid;
-  /* Delete the shield cache, if it exists. */
+  /* Delete the shield queue, if it exists. */
   if (shield->length != 0) {
-    AVER(shield->cache != NULL);
-    ControlFree(arena, shield->cache,
-                shield->length * sizeof shield->cache[0]);
-    shield->cache = NULL;
+    AVER(shield->queue != NULL);
+    ControlFree(arena, shield->queue,
+                shield->length * sizeof shield->queue[0]);
+    shield->queue = NULL;
     shield->length = 0;
   }
 }
@@ -46,9 +46,9 @@ Bool ShieldCheck(Shield shield)
 {
   CHECKS(Shield, shield);
   CHECKL(BoolCheck(shield->inside));
-  CHECKL(shield->cache == NULL || shield->length > 0);
+  CHECKL(shield->queue == NULL || shield->length > 0);
   CHECKL(shield->limit <= shield->length);
-  CHECKL(shield->i <= shield->limit);
+  CHECKL(shield->next <= shield->limit);
   CHECKL(BoolCheck(shield->suspended));
 
   /* The mutator is not suspended while outside the shield
@@ -64,14 +64,14 @@ Bool ShieldCheck(Shield shield)
   CHECKL(shield->inside || shield->depth == 0);
 
   /* This is too expensive to check all the time since we have an
-     expanding shield cache that often has 16K elements instead of
+     expanding shield queue that often has 16K elements instead of
      16. */
 #if defined(AVER_AND_CHECK_ALL)
   {
     Count depth = 0;
     Index i;
     for (i = 0; i < shield->limit; ++i) {
-      Seg seg = shield->cache[i];
+      Seg seg = shield->queue[i];
       CHECKD(Seg, seg);
       depth += SegDepth(seg);
     }
@@ -91,7 +91,7 @@ Res ShieldDescribe(Shield shield, mps_lib_FILE *stream, Count depth)
                shield->inside ? "inside" : "outside", " shield\n",
                "suspended $S\n", WriteFYesNo(shield->suspended),
                "shield depth $U\n", (WriteFU)shield->depth,
-               "shield i $U\n", (WriteFU)shield->i,
+               "shield next $U\n", (WriteFU)shield->next,
                "shield length $U\n", (WriteFU)shield->length,
                NULL);
   if (res != ResOK)
@@ -221,43 +221,43 @@ static void shieldProtLower(Seg seg, AccessSet mode)
 }
 
 
-/* shieldDecache -- remove a segment from the shield cache */
+/* shieldDequeue -- remove a segment from the shield queue */
 
-static Seg shieldDecache(Shield shield, Index i)
+static Seg shieldDequeue(Shield shield, Index i)
 {
   Seg seg;
   AVER(i < shield->limit);
-  seg = shield->cache[i];
+  seg = shield->queue[i];
   AVERT(Seg, seg);
-  AVER(seg->cached);
-  shield->cache[i] = NULL;
-  seg->cached = FALSE;
+  AVER(seg->queued);
+  shield->queue[i] = NULL;
+  seg->queued = FALSE;
   return seg;
 }
 
 
-/* shieldFlushEntry -- flush a single entry from the cache */
+/* shieldFlushEntry -- flush a single entry from the queue */
 
 static void shieldFlushEntry(Shield shield, Index i)
 {
-  Seg seg = shieldDecache(shield, i);
+  Seg seg = shieldDequeue(shield, i);
 
   if (!SegIsExposed(seg))
     shieldSync(shield, seg);
 }
 
 
-/* shieldCacheReset -- reset shield cache pointers */
+/* shieldQueueReset -- reset shield queue pointers */
 
-static void shieldCacheReset(Shield shield)
+static void shieldQueueReset(Shield shield)
 {
-  AVER(shield->depth == 0); /* overkill: implies no segs are cached */
-  shield->i = 0;
+  AVER(shield->depth == 0); /* overkill: implies no segs are queued */
+  shield->next = 0;
   shield->limit = 0;
 }
 
 
-/* shieldCacheEntryCompare -- comparison for cache sorting */
+/* shieldQueueEntryCompare -- comparison for queue sorting */
 
 static Compare shieldAddrCompare(Addr left, Addr right)
 {
@@ -269,7 +269,7 @@ static Compare shieldAddrCompare(Addr left, Addr right)
     return CompareGREATER;
 }
 
-static Compare shieldCacheEntryCompare(void *left, void *right, void *closure)
+static Compare shieldQueueEntryCompare(void *left, void *right, void *closure)
 {
   Seg segA = left, segB = right;
 
@@ -283,16 +283,16 @@ static Compare shieldCacheEntryCompare(void *left, void *right, void *closure)
 }
 
 
-/* shieldFlushEntries -- flush cache coalescing protects
+/* shieldFlushEntries -- flush queue coalescing protects
  *
- * Sort the shield cache into address order, then iterate over it
+ * Sort the shield queue into address order, then iterate over it
  * coalescing protection work, in order to reduce the number of system
  * calls to a minimum.  This is very important on OS X, where
  * protection calls are extremely inefficient, but has no net gain on
  * Windows.
  *
  * TODO: Could we keep extending the outstanding area over memory
- * that's *not* in the cache but has the same protection mode?  Might
+ * that's *not* in the queue but has the same protection mode?  Might
  * require design.mps.shield.improve.noseg.
  */
 
@@ -303,16 +303,16 @@ static void shieldFlushEntries(Shield shield)
   Index i;
 
   if (shield->length == 0) {
-    AVER(shield->cache == NULL);
+    AVER(shield->queue == NULL);
     return;
   }
 
-  QuickSort((void *)shield->cache, shield->limit,
-            shieldCacheEntryCompare, UNUSED_POINTER);
+  QuickSort((void *)shield->queue, shield->limit,
+            shieldQueueEntryCompare, UNUSED_POINTER);
 
   mode = AccessSetEMPTY;
   for (i = 0; i < shield->limit; ++i) {
-    Seg seg = shieldDecache(shield, i);
+    Seg seg = shieldDequeue(shield, i);
     if (!SegIsSynced(seg)) {
       AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
       SegSetPM(seg, SegSM(seg));
@@ -334,17 +334,17 @@ static void shieldFlushEntries(Shield shield)
     ProtSet(base, limit, mode);
   }
 
-  shieldCacheReset(shield);
+  shieldQueueReset(shield);
 }
 
 
-/* shieldCache -- consider adding a segment to the cache
+/* shieldQueue -- consider adding a segment to the queue
  *
  * If the segment is out of sync, either sync it, or ensure it is
- * cached and the arena is suspended.
+ * queued and the arena is suspended.
  */
 
-static void shieldCache(Arena arena, Seg seg)
+static void shieldQueue(Arena arena, Seg seg)
 {
   Shield shield;
   
@@ -353,50 +353,50 @@ static void shieldCache(Arena arena, Seg seg)
   shield = ArenaShield(arena);
   SHIELD_AVERT_CRITICAL(Seg, seg);
 
-  if (SegIsSynced(seg) || seg->cached)
+  if (SegIsSynced(seg) || seg->queued)
     return;
 
   if (SegIsExposed(seg)) {
     /* This can occur if the mutator isn't suspended, we expose a
        segment, then raise the shield on it.  In this case, the
        mutator isn't allowed to see the segment, but we don't need to
-       cache it until its covered. */
+       queue it until its covered. */
     ShieldSuspend(arena);
     return;
   }
 
-  /* Allocate shield cache if necessary. */
-  /* TODO: This will try to extend the cache on every attempt, even
+  /* Allocate shield queue if necessary. */
+  /* TODO: This will try to extend the queue on every attempt, even
      if it failed last time. That might be slow. */
-  if (shield->i >= shield->length) {
+  if (shield->next >= shield->length) {
     void *p;
     Res res;
     Count length;
 
-    AVER(shield->i == shield->length);
+    AVER(shield->next == shield->length);
 
     if (shield->length == 0)
-      length = ShieldCacheLENGTH;
+      length = ShieldQueueLENGTH;
     else
       length = shield->length * 2;
     
-    res = ControlAlloc(&p, arena, length * sizeof shield->cache[0]);
+    res = ControlAlloc(&p, arena, length * sizeof shield->queue[0]);
     if (res != ResOK) {
       AVER(ResIsAllocFailure(res));
-      /* Carry on with the existing cache. */
+      /* Carry on with the existing queue. */
     } else {
       if (shield->length > 0) {
-        Size oldSize = shield->length * sizeof shield->cache[0];
-        AVER(shield->cache != NULL);
-        mps_lib_memcpy(p, shield->cache, oldSize);
-        ControlFree(arena, shield->cache, oldSize);
+        Size oldSize = shield->length * sizeof shield->queue[0];
+        AVER(shield->queue != NULL);
+        mps_lib_memcpy(p, shield->queue, oldSize);
+        ControlFree(arena, shield->queue, oldSize);
       }
-      shield->cache = p;
+      shield->queue = p;
       shield->length = length;
     }
   }
 
-  /* Cache unavailable, so synchronize now.  Or if the mutator is not
+  /* Queue unavailable, so synchronize now.  Or if the mutator is not
      yet suspended and the code raises the shield on a covered
      segment, protect it now, because that's probably better than
      suspending the mutator. */
@@ -406,36 +406,36 @@ static void shieldCache(Arena arena, Seg seg)
   }
 
   AVER_CRITICAL(shield->limit <= shield->length);
-  AVER_CRITICAL(shield->i <= shield->limit);
+  AVER_CRITICAL(shield->next <= shield->limit);
 
-  if (shield->i >= shield->length)
-    shield->i = 0;
-  AVER_CRITICAL(shield->i < shield->length);
+  if (shield->next >= shield->length)
+    shield->next = 0;
+  AVER_CRITICAL(shield->next < shield->length);
 
   AVER_CRITICAL(shield->length > 0);
 
-  /* If the limit is less than the length, then the cache array has
-     yet to be filled, and shCacheI is an uninitialized entry.
+  /* If the limit is less than the length, then the queue array has
+     yet to be filled, and next is an uninitialized entry.
      Otherwise it's the tail end from last time around, and needs to
      be flushed. */
   if (shield->limit >= shield->length) {
     AVER_CRITICAL(shield->limit == shield->length);
-    shieldFlushEntry(shield, shield->i);
+    shieldFlushEntry(shield, shield->next);
   }
 
-  shield->cache[shield->i] = seg;
-  ++shield->i;
-  seg->cached = TRUE;
+  shield->queue[shield->next] = seg;
+  ++shield->next;
+  seg->queued = TRUE;
 
-  if (shield->i >= shield->limit)
-    shield->limit = shield->i;
+  if (shield->next >= shield->limit)
+    shield->limit = shield->next;
 }
 
 
 /* ShieldRaise -- declare segment should be protected from mutator
  *
  * Does not immediately protect the segment, unless the segment is
- * covered and the shield cache is unavailable.
+ * covered and the shield queue is unavailable.
  */
 
 void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
@@ -450,9 +450,9 @@ void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
   SegSetSM(seg, SegSM(seg) | mode); /* .inv.prot.shield preserved */
 
   /* ensure .inv.unsynced.suspended and .inv.unsynced.depth */
-  shieldCache(arena, seg);
+  shieldQueue(arena, seg);
 
-  /* Check cache and segment consistency. */
+  /* Check queue and segment consistency. */
   AVERT(Arena, arena);
   AVERT(Seg, seg);
 }
@@ -476,7 +476,7 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
      violate design.mps.shield.prop.inside.access. */
   shieldProtLower(seg, mode);
 
-  /* Check cache and segment consistency. */
+  /* Check queue and segment consistency. */
   AVERT(Arena, arena);
   AVERT(Seg, seg);
 }
@@ -494,7 +494,7 @@ void (ShieldEnter)(Arena arena)
   AVER(shield->depth == 0);
   AVER(!shield->suspended);
 
-  shieldCacheReset(shield);
+  shieldQueueReset(shield);
 
   shield->inside = TRUE;
 }
@@ -509,7 +509,7 @@ void (ShieldEnter)(Arena arena)
  * try enabling SHIELD_DEBUG and extending this code as necessary.
  *
  * The basic idea is to iterate over *all* segments and check
- * consistency with the arena and shield cache.
+ * consistency with the arena and shield queue.
  */
 
 #if defined(SHIELD_DEBUG)
@@ -517,7 +517,7 @@ static void shieldDebugCheck(Arena arena)
 {
   Shield shield;
   Seg seg;
-  Count cached = 0;
+  Count queued = 0;
 
   AVERT(Arena, arena);
   shield = ShieldArena(arena);
@@ -526,27 +526,27 @@ static void shieldDebugCheck(Arena arena)
   if (SegFirst(&seg, arena))
     do {
       if (shield->limit == 0) {
-        AVER(!seg->cached);
+        AVER(!seg->queued);
         AVER(SegIsSynced(seg));
         /* You can directly set protections here to see if it makes a
            difference. */
         /* ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg)); */
       } else {
-        if (seg->cached)
-          ++cached;
+        if (seg->queued)
+          ++queued;
       }
     } while(SegNext(&seg, arena, seg));
 
-  AVER(cached == shield->limit);
+  AVER(queued == shield->limit);
 }
 #endif
 
 
-/* ShieldFlush -- empty the shield cache
+/* ShieldFlush -- empty the shield queue
  *
- * .shield.flush: Flush empties the shield cache.  This needs to be
- * called before segments in the cache are destroyed, as there may be
- * references to them in the cache.
+ * .shield.flush: Flush empties the shield queue.  This needs to be
+ * called before segments in the queue are destroyed, as there may be
+ * references to them in the queue.
  *
  * The memory for the segment may become spare, and not released back
  * to the operating system. Since we keep track of protection on
@@ -566,7 +566,7 @@ void (ShieldFlush)(Arena arena)
   shieldDebugCheck(arena);
 #endif
   shieldFlushEntries(shield);
-  /* Cache is empty so .inv.outside.depth holds */
+  /* Queue is empty so .inv.outside.depth holds */
   AVER(shield->depth == 0);
 #ifdef SHIELD_DEBUG
   shieldDebugCheck(arena);
@@ -648,7 +648,7 @@ void (ShieldCover)(Arena arena, Seg seg)
   --shield->depth;
 
   /* Ensure design.mps.shield.inv.unsynced.depth. */
-  shieldCache(arena, seg);
+  shieldQueue(arena, seg);
 }
 
 
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 57c2e309ae0..03a3c2a1c31 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -115,9 +115,9 @@ segment should be unprotected, and the Shield could re-instate
 hardware protection.
 
 However, as a performance-improving hysteresis, the Shield defers
-re-protection, maintaining a cache of segments that no longer have a
-reason to be collector-accessible.  While a segment is in the cache,
-it has ``seg->cached`` set to TRUE.
+re-protection, maintaining a queue of segments that no longer have a
+reason to be collector-accessible.  While a segment is in the queue,
+it has ``seg->queued`` set to TRUE.
 
 This hysteresis allows the MPS to proceed with garbage collection
 during a pause without actually setting hardware protection until it
@@ -130,7 +130,7 @@ implemented, such as OS X.
 So whenever hardware protection is temporarily removed to allow
 collector access, there is a *nurse* that will ensure this protection
 is re-established: the nurse is either the balancing ``ShieldCover()``
-call in collector code, or an entry in the shield cache.
+call in collector code, or an entry in the shield queue.
 
 
 Implementation
@@ -138,8 +138,8 @@ Implementation
 
 .impl.delay: The implementation of the shield avoids suspending
 threads for as long as possible.  When threads are suspended, it
-maintains a cache of covered segments where the desired and actual
-protection do not match.  This cache is flushed on leaving the shield.
+maintains a queue of covered segments where the desired and actual
+protection do not match.  This queue is flushed on leaving the shield.
 
 
 Definitions
@@ -157,7 +157,7 @@ same, and unsynced otherwise.
   |    #exposes = the total number of times the seg has been exposed
   |    #covers  = the total number of times the seg has been covered
 
-The cache is initially empty and ``ShieldCover`` should not be called
+The queue is initially empty and ``ShieldCover`` should not be called
 without a matching ``ShieldExpose``, so this figure should always be
 non-negative.
 
@@ -198,7 +198,7 @@ shield.
 suspended.
 
 .inv.unsynced.depth: All unsynced segments have positive depth or are
-in the cache.
+in the queue.
 
 .inv.outside.depth: The total depth is zero while outside the shield.
 
@@ -249,7 +249,7 @@ Mass exposure
 .improv.mass-expose: If protection calls have a high overhead it might
 be good to pre-emptively unprotect large ranges of memory when we
 expose one segment.  With the current design this would mean
-discovering adjacent shielded segments and adding them to the cache.
+discovering adjacent shielded segments and adding them to the queue.
 The collector should take advantage of this by preferentially scanning
 exposed segments during a pause.
 
@@ -259,7 +259,7 @@ Segment independence
 
 .improve.noseg: The shield is implemented in terms of segments, using
 fields in the segment structure to represent its state. This forces us
-to (for example) flush the shield cache when deleting a segment. The
+to (for example) flush the shield queue when deleting a segment. The
 shield could keep track of protection and shielding independently,
 possibly allowing greater coalescing and more efficient and flexible
 use of system calls (see .improve.mass-expose).
@@ -319,10 +319,10 @@ Document History
 
 - 2013-05-24 GDR_ Converted to reStructuredText.
 
-- 2016-03-17 RB_ Updated for dynamic cacheing and general code tidying
+- 2016-03-17 RB_ Updated for dynamic queueing and general code tidying
   that has removed complaints.
 
-- 2016-03-19 RB_ Updated for separate cache flag on segments, changes
+- 2016-03-19 RB_ Updated for separate queued flag on segments, changes
   of invariants, cross-references, and ideas for future improvement.
 
 .. _GDR: http://www.ravenbrook.com/consultants/gdr/

From a03174304da3a889e6a01012887e2879b623a96a Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 20 Mar 2016 01:01:54 +0000
Subject: [PATCH 36/69] Tearing down shield correctly.

Copied from Perforce
 Change: 190225
 ServerID: perforce.ravenbrook.com
---
 mps/code/global.c  | 11 ++++++-----
 mps/code/mpm.h     |  4 +++-
 mps/code/poolmrg.c |  2 +-
 mps/code/shield.c  | 15 +++++++++------
 4 files changed, 19 insertions(+), 13 deletions(-)

diff --git a/mps/code/global.c b/mps/code/global.c
index 111404d03f8..d1665254a60 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -154,7 +154,7 @@ Bool GlobalsCheck(Globals arenaGlobals)
   CHECKD_NOSIG(Ring, &arena->threadRing);
   CHECKD_NOSIG(Ring, &arena->deadRing);
 
-  CHECKD_NOSIG(Shield, &arena->shieldStruct); /* FIXME: Sig */
+  CHECKD(Shield, ArenaShield(arena));
 
   CHECKL(TraceSetCheck(arena->busyTraces));
   CHECKL(TraceSetCheck(arena->flippedTraces));
@@ -280,7 +280,7 @@ Res GlobalsInit(Globals arenaGlobals)
   arena->tracedWork = 0.0;
   arena->tracedTime = 0.0;
   arena->lastWorldCollect = ClockNow();
-  ShieldInit(&arena->shieldStruct);
+  ShieldInit(ArenaShield(arena));
 
   for (ti = 0; ti < TraceLIMIT; ++ti) {
     /* <design/arena/#trace.invalid> */
@@ -385,6 +385,7 @@ void GlobalsFinish(Globals arenaGlobals)
 
   arenaGlobals->sig = SigInvalid;
 
+  ShieldFinish(ArenaShield(arena));
   RingFinish(&arena->formatRing);
   RingFinish(&arena->chainRing);
   RingFinish(&arena->messageRing);
@@ -418,8 +419,6 @@ void GlobalsPrepareToDestroy(Globals arenaGlobals)
 
   arena = GlobalsArena(arenaGlobals);
 
-  ShieldFinish(&arena->shieldStruct, arena);
-
   arenaDenounce(arena);
 
   defaultChain = arenaGlobals->defaultChain;
@@ -471,6 +470,8 @@ void GlobalsPrepareToDestroy(Globals arenaGlobals)
     PoolDestroy(pool);
   }
 
+  ShieldDestroyQueue(ArenaShield(arena), arena);
+
   /* Check that the tear-down is complete: that the client has
    * destroyed all data structures associated with the arena. We do
    * this here rather than in GlobalsFinish because by the time that
@@ -1001,7 +1002,7 @@ Res GlobalsDescribe(Globals arenaGlobals, mps_lib_FILE *stream, Count depth)
       return res;
   }
 
-  res = ShieldDescribe(&arena->shieldStruct, stream, depth);
+  res = ShieldDescribe(ArenaShield(arena), stream, depth);
   if (res != ResOK)
     return res;
 
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index 21e9e82182a..ff64ccba362 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -534,6 +534,7 @@ extern Ring GlobalsRememberedSummaryRing(Globals);
 #define ArenaGreyRing(arena, rank) (&(arena)->greyRing[rank])
 #define ArenaPoolRing(arena) (&ArenaGlobals(arena)->poolRing)
 #define ArenaChunkTree(arena) RVALUE((arena)->chunkTree)
+#define ArenaShield(arena)      (&(arena)->shieldStruct)
 
 extern Bool ArenaGrainSizeCheck(Size size);
 #define AddrArenaGrainUp(addr, arena) AddrAlignUp(addr, ArenaGrainSize(arena))
@@ -908,9 +909,10 @@ extern ZoneSet ZoneSetBlacklist(Arena arena);
 /* Shield Interface -- see <code/shield.c> */
 
 extern void ShieldInit(Shield shield);
-extern void ShieldFinish(Shield shield, Arena arena);
+extern void ShieldFinish(Shield shield);
 extern Bool ShieldCheck(Shield shield);
 extern Res ShieldDescribe(Shield shield, mps_lib_FILE *stream, Count depth);
+extern void ShieldDestroyQueue(Shield shield, Arena arena);
 extern void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode);
 extern void (ShieldLower)(Arena arena, Seg seg, AccessSet mode);
 extern void (ShieldEnter)(Arena arena);
diff --git a/mps/code/poolmrg.c b/mps/code/poolmrg.c
index 554ec2a7319..cc1cab67975 100644
--- a/mps/code/poolmrg.c
+++ b/mps/code/poolmrg.c
@@ -821,7 +821,7 @@ static Res MRGDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
   if (res != ResOK)
     return res;
   RING_FOR(node, &mrg->entryRing, nextNode) {
-    Bool outsideShield = !arena->shieldStruct.inside;
+    Bool outsideShield = !ArenaShield(arena)->inside;
     refPart = MRGRefPartOfLink(linkOfRing(node), arena);
     if (outsideShield) {
       ShieldEnter(arena);
diff --git a/mps/code/shield.c b/mps/code/shield.c
index ecabcf96dc3..3e957966a05 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -28,10 +28,10 @@ void ShieldInit(Shield shield)
 }
 
 
-void ShieldFinish(Shield shield, Arena arena)
+void ShieldDestroyQueue(Shield shield, Arena arena)
 {
-  shield->sig = SigInvalid;
-  /* Delete the shield queue, if it exists. */
+  AVER(shield->limit == 0);
+  
   if (shield->length != 0) {
     AVER(shield->queue != NULL);
     ControlFree(arena, shield->queue,
@@ -42,6 +42,12 @@ void ShieldFinish(Shield shield, Arena arena)
 }
 
 
+void ShieldFinish(Shield shield)
+{
+  shield->sig = SigInvalid;
+}
+
+
 Bool ShieldCheck(Shield shield)
 {
   CHECKS(Shield, shield);
@@ -101,9 +107,6 @@ Res ShieldDescribe(Shield shield, mps_lib_FILE *stream, Count depth)
 }
 
 
-#define ArenaShield(arena) (&(arena)->shieldStruct)
-
-
 /* SHIELD_AVER -- transgressive argument checking
  *
  * .trans.check: A number of shield functions cannot do normal

From 5e62e27402972030af884bf37a5b68b1c552a782 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 20 Mar 2016 01:22:15 +0000
Subject: [PATCH 37/69] Fixing splitting and merging for queued segments.

Copied from Perforce
 Change: 190228
 ServerID: perforce.ravenbrook.com
---
 mps/code/seg.c     | 14 ++++++++++----
 mps/code/shield.c  |  7 ++++---
 mps/design/seg.txt |  8 ++++----
 3 files changed, 18 insertions(+), 11 deletions(-)

diff --git a/mps/code/seg.c b/mps/code/seg.c
index 71fee6a4a1e..64fb86c2d28 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -573,7 +573,8 @@ Res SegMerge(Seg *mergedSegReturn, Seg segLo, Seg segHi)
   AVER(SegBase(segHi) == SegLimit(segLo));
   arena = PoolArena(SegPool(segLo));
 
-  ShieldFlush(arena);  /* see <design/seg/#split-merge.shield> */
+  if (segLo->queued || segHi->queued)
+    ShieldFlush(arena);  /* see <design/seg/#split-merge.shield> */
 
   /* Invoke class-specific methods to do the merge */
   res = class->merge(segLo, segHi, base, mid, limit);
@@ -625,7 +626,9 @@ Res SegSplit(Seg *segLoReturn, Seg *segHiReturn, Seg seg, Addr at)
    * the split point. */
   AVER(SegBuffer(seg) == NULL || BufferLimit(SegBuffer(seg)) <= at);
 
-  ShieldFlush(arena);  /* see <design/seg/#split-merge.shield> */
+  if (seg->queued)
+    ShieldFlush(arena);  /* see <design/seg/#split-merge.shield> */
+  AVER(SegSM(seg) == SegPM(seg));
 
   /* Allocate the new segment object from the control pool */
   res = ControlAlloc(&p, arena, class->size);
@@ -899,9 +902,11 @@ static Res segTrivMerge(Seg seg, Seg segHi,
   AVER(seg->pm == segHi->pm);
   AVER(seg->sm == segHi->sm);
   AVER(seg->depth == segHi->depth);
+  AVER(seg->queued == segHi->queued);
   /* Neither segment may be exposed, or in the shield cache */
   /* See <design/seg/#split-merge.shield> & <code/shield.c#def.depth> */
   AVER(seg->depth == 0);
+  AVER(!seg->queued);
 
   /* no need to update fields which match. See .similar */
 
@@ -938,7 +943,6 @@ static Res segNoSplit(Seg seg, Seg segHi,
   AVER(SegLimit(seg) == limit);
   NOTREACHED;
   return ResFAIL;
-
 }
 
 
@@ -964,9 +968,10 @@ static Res segTrivSplit(Seg seg, Seg segHi,
   AVER(SegBase(seg) == base);
   AVER(SegLimit(seg) == limit);
 
-  /* Segment may not be exposed, or in the shield cache */
+  /* Segment may not be exposed, or in the shield queue */
   /* See <design/seg/#split-merge.shield> & <code/shield.c#def.depth> */
   AVER(seg->depth == 0);
+  AVER(!seg->queued);
  
   /* Full initialization for segHi. Just modify seg. */
   seg->limit = mid;
@@ -978,6 +983,7 @@ static Res segTrivSplit(Seg seg, Seg segHi,
   segHi->pm = seg->pm;
   segHi->sm = seg->sm;
   segHi->depth = seg->depth;
+  segHi->queued = seg->queued;
   segHi->firstTract = NULL;
   segHi->class = seg->class;
   segHi->sig = SegSig;
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 3e957966a05..f7cc4aef672 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -30,7 +30,7 @@ void ShieldInit(Shield shield)
 
 void ShieldDestroyQueue(Shield shield, Arena arena)
 {
-  AVER(shield->limit == 0);
+  AVER(shield->limit == 0); /* queue must be empty */
   
   if (shield->length != 0) {
     AVER(shield->queue != NULL);
@@ -81,7 +81,7 @@ Bool ShieldCheck(Shield shield)
       CHECKD(Seg, seg);
       depth += SegDepth(seg);
     }
-    CHECKL(depth <= shield->depth);
+    CHECKL(depth == shield->depth);
   }
 #endif
 
@@ -201,7 +201,8 @@ void (ShieldResume)(Arena arena)
   AVER(shield->inside);
   AVER(shield->suspended);
 
-  /* It is only correct to actually resume the mutator here if shDepth is 0 */
+  /* It is only correct to actually resume the mutator here if
+     shield->depth is 0 and the queue is empty. */
   /* TODO: Consider actually doing that. */
 }
 
diff --git a/mps/design/seg.txt b/mps/design/seg.txt
index 1a25926ffd5..dc9e8b96083 100644
--- a/mps/design/seg.txt
+++ b/mps/design/seg.txt
@@ -268,14 +268,14 @@ design.mps.protocol.overview.next-method_).
 .. _design.mps.protocol.overview.next-method: protocol#overview.next-method
 
 _`.split-merge.shield`: Split and merge methods may assume that the
-segments they are manipulating are not in the shield cache.
+segments they are manipulating are not in the shield queue.
 
-_`.split-merge.shield.flush`: The shield cache is flushed before any
+_`.split-merge.shield.flush`: The shield queue is flushed before any
 split or merge methods are invoked.
 
 _`.split-merge.shield.re-flush`: If a split or merge method performs
-an operation on a segment which might cause the segment to be cached,
-the method must flush the shield cache before returning or calling
+an operation on a segment which might cause the segment to be queued,
+the method must flush the shield queue before returning or calling
 another split or merge method.
 
 _`.split-merge.fail`: Split and merge methods might fail, in which

From cc0b4af900c847e91a8b8c5e77d084335faf6417 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 20 Mar 2016 12:43:13 +0000
Subject: [PATCH 38/69] Reinstate -ansi flag on strict clang builds, which
 somehow got lost.

Copied from Perforce
 Change: 190233
 ServerID: perforce.ravenbrook.com
---
 mps/code/ll.gmk | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/mps/code/ll.gmk b/mps/code/ll.gmk
index 787380fb3ed..1bdbef3afcb 100644
--- a/mps/code/ll.gmk
+++ b/mps/code/ll.gmk
@@ -32,7 +32,7 @@ CFLAGSCOMPILER := \
 	-Wstrict-prototypes \
 	-Wunreachable-code \
 	-Wwrite-strings
-CFLAGSCOMPILERSTRICT :=
+CFLAGSCOMPILERSTRICT := -ansi
 
 # A different set of compiler flags for less strict compilation, for
 # instance when we need to #include a third-party header file that

From 394b28a73b6eb68021449d0d625caef63c9462ec Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 20 Mar 2016 12:46:50 +0000
Subject: [PATCH 39/69] Fixing compiler warnings.

Copied from Perforce
 Change: 190237
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/mps/code/mpm.c b/mps/code/mpm.c
index 7d944ae57eb..f2ea2acb27a 100644
--- a/mps/code/mpm.c
+++ b/mps/code/mpm.c
@@ -657,10 +657,10 @@ static unsigned RandomSeed = 1;
 #define Random_a 48271UL
 unsigned Random32(void)
 {
-  AVER(UINT_MAX >= 4294967295U);
   /* requires m == 2^31-1, a < 2^16 */
   unsigned bot = Random_a * (RandomSeed & 0x7FFF);
   unsigned top = Random_a * (RandomSeed >> 15);
+  AVER(UINT_MAX >= 4294967295U);
   RandomSeed = bot + ((top & 0xFFFF) << 15) + (top >> 16);
   if (RandomSeed > Random_m)
     RandomSeed -= Random_m;
@@ -669,7 +669,7 @@ unsigned Random32(void)
 
 Word RandomWord(void)
 {
-  Word word;
+  Word word = 0;
   Index i;
   for (i = 0; i < MPS_WORD_WIDTH; i += 31)
     word = (word << 31) | Random32();

From f15f64c347a0adf04306f518a54709191461c72a Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sat, 19 Mar 2016 19:43:01 +0000
Subject: [PATCH 40/69] Clarifying that padding object sizes won't match pool
 object sizes.

Copied from Perforce
 Change: 190242
 ServerID: perforce.ravenbrook.com
---
 mps/manual/source/topic/format.rst | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/mps/manual/source/topic/format.rst b/mps/manual/source/topic/format.rst
index 7db5c8a1178..ec1f707aea3 100644
--- a/mps/manual/source/topic/format.rst
+++ b/mps/manual/source/topic/format.rst
@@ -368,6 +368,12 @@ Format methods
         object format has a non-zero
         :c:macro:`MPS_KEY_FMT_HEADER_SIZE`.
 
+   .. note::
+
+        The MPS will ask for padding objects of any size aligned to
+        the pool alignment, no matter what size objects the pool
+        holds.  For example, a pool holding only two-word objects may
+        still be asked to create padding objects 2048 bytes long.
 
 .. c:type:: mps_res_t (*mps_fmt_scan_t)(mps_ss_t ss, mps_addr_t base, mps_addr_t limit)
 

From e8c2a85e825bf5e19cdc65a202cffc2e589eaf59 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 20 Mar 2016 15:57:52 +0000
Subject: [PATCH 41/69] Consistent use of -std=c89 for gcc and clang on all
 platforms.

Copied from Perforce
 Change: 190243
 ServerID: perforce.ravenbrook.com
---
 mps/code/gc.gmk                        | 2 +-
 mps/code/ll.gmk                        | 3 +--
 mps/code/mps.xcodeproj/project.pbxproj | 6 +++---
 3 files changed, 5 insertions(+), 6 deletions(-)

diff --git a/mps/code/gc.gmk b/mps/code/gc.gmk
index 76716dc0785..f43e455dcd8 100644
--- a/mps/code/gc.gmk
+++ b/mps/code/gc.gmk
@@ -27,7 +27,7 @@ CFLAGSCOMPILER := \
 	-Wstrict-prototypes \
 	-Wswitch-default \
 	-Wwrite-strings
-CFLAGSCOMPILERSTRICT := -ansi -pedantic
+CFLAGSCOMPILERSTRICT := -std=c89 -pedantic
 
 # A different set of compiler flags for less strict compilation, for
 # instance when we need to #include a third-party header file that
diff --git a/mps/code/ll.gmk b/mps/code/ll.gmk
index 1bdbef3afcb..db30cde45f0 100644
--- a/mps/code/ll.gmk
+++ b/mps/code/ll.gmk
@@ -13,7 +13,6 @@ CC = clang
 CFLAGSDEBUG = -O0 -g3
 CFLAGSOPT = -O2 -g3
 CFLAGSCOMPILER := \
-	-pedantic \
 	-Waggregate-return \
 	-Wall \
 	-Wcast-qual \
@@ -32,7 +31,7 @@ CFLAGSCOMPILER := \
 	-Wstrict-prototypes \
 	-Wunreachable-code \
 	-Wwrite-strings
-CFLAGSCOMPILERSTRICT := -ansi
+CFLAGSCOMPILERSTRICT := -std=c89 -pedantic
 
 # A different set of compiler flags for less strict compilation, for
 # instance when we need to #include a third-party header file that
diff --git a/mps/code/mps.xcodeproj/project.pbxproj b/mps/code/mps.xcodeproj/project.pbxproj
index 9cfea1da0d3..9af36ed62a8 100644
--- a/mps/code/mps.xcodeproj/project.pbxproj
+++ b/mps/code/mps.xcodeproj/project.pbxproj
@@ -5311,7 +5311,7 @@
 				SDKROOT = macosx;
 				SYMROOT = xc;
 				WARNING_CFLAGS = (
-					"-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
+					"-std=c89\n-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
 				);
 			};
 			name = RASH;
@@ -5734,7 +5734,7 @@
 				SDKROOT = macosx;
 				SYMROOT = xc;
 				WARNING_CFLAGS = (
-					"-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
+					"-std=c89\n-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
 				);
 			};
 			name = Debug;
@@ -5775,7 +5775,7 @@
 				SDKROOT = macosx;
 				SYMROOT = xc;
 				WARNING_CFLAGS = (
-					"-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
+					"-std=c89\n-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
 				);
 			};
 			name = Release;

From 7ec5dac2bb43a9f29c213f7f00a233d943941f86 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Mon, 21 Mar 2016 10:06:23 +0000
Subject: [PATCH 42/69] Fixing language standard to c89 for the mps, except
 mpseventsql which uses c99 extensions such as strtoull.

Copied from Perforce
 Change: 190254
 ServerID: perforce.ravenbrook.com
---
 mps/code/mps.xcodeproj/project.pbxproj | 63 +++++++++++++++++++++++---
 1 file changed, 57 insertions(+), 6 deletions(-)

diff --git a/mps/code/mps.xcodeproj/project.pbxproj b/mps/code/mps.xcodeproj/project.pbxproj
index 9af36ed62a8..c71c9d86684 100644
--- a/mps/code/mps.xcodeproj/project.pbxproj
+++ b/mps/code/mps.xcodeproj/project.pbxproj
@@ -5284,7 +5284,7 @@
 				CLANG_WARN_SUSPICIOUS_IMPLICIT_CONVERSION = YES;
 				CLANG_WARN__DUPLICATE_METHOD_MATCH = YES;
 				DEBUG_INFORMATION_FORMAT = "dwarf-with-dsym";
-				GCC_C_LANGUAGE_STANDARD = ansi;
+				GCC_C_LANGUAGE_STANDARD = c89;
 				GCC_OPTIMIZATION_LEVEL = s;
 				GCC_PREPROCESSOR_DEFINITIONS = CONFIG_VAR_RASH;
 				GCC_TREAT_IMPLICIT_FUNCTION_DECLARATIONS_AS_ERRORS = YES;
@@ -5311,7 +5311,24 @@
 				SDKROOT = macosx;
 				SYMROOT = xc;
 				WARNING_CFLAGS = (
-					"-std=c89\n-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
+					"-pedantic",
+					"-Waggregate-return",
+					"-Wall",
+					"-Wcast-qual",
+					"-Wconversion",
+					"-Wduplicate-enum",
+					"-Wextra",
+					"-Winline",
+					"-Wmissing-prototypes",
+					"-Wmissing-variable-declarations",
+					"-Wnested-externs",
+					"-Wno-extended-offsetof",
+					"-Wpointer-arith",
+					"-Wshadow",
+					"-Wstrict-aliasing=2",
+					"-Wstrict-prototypes",
+					"-Wunreachable-code",
+					"-Wwrite-strings",
 				);
 			};
 			name = RASH;
@@ -5706,7 +5723,7 @@
 				CLANG_WARN_SUSPICIOUS_IMPLICIT_CONVERSION = YES;
 				CLANG_WARN__DUPLICATE_METHOD_MATCH = YES;
 				COPY_PHASE_STRIP = NO;
-				GCC_C_LANGUAGE_STANDARD = ansi;
+				GCC_C_LANGUAGE_STANDARD = c89;
 				GCC_OPTIMIZATION_LEVEL = 0;
 				GCC_PREPROCESSOR_DEFINITIONS = CONFIG_VAR_COOL;
 				GCC_TREAT_IMPLICIT_FUNCTION_DECLARATIONS_AS_ERRORS = YES;
@@ -5734,7 +5751,24 @@
 				SDKROOT = macosx;
 				SYMROOT = xc;
 				WARNING_CFLAGS = (
-					"-std=c89\n-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
+					"-pedantic",
+					"-Waggregate-return",
+					"-Wall",
+					"-Wcast-qual",
+					"-Wconversion",
+					"-Wduplicate-enum",
+					"-Wextra",
+					"-Winline",
+					"-Wmissing-prototypes",
+					"-Wmissing-variable-declarations",
+					"-Wnested-externs",
+					"-Wno-extended-offsetof",
+					"-Wpointer-arith",
+					"-Wshadow",
+					"-Wstrict-aliasing=2",
+					"-Wstrict-prototypes",
+					"-Wunreachable-code",
+					"-Wwrite-strings",
 				);
 			};
 			name = Debug;
@@ -5748,7 +5782,7 @@
 				CLANG_WARN_SUSPICIOUS_IMPLICIT_CONVERSION = YES;
 				CLANG_WARN__DUPLICATE_METHOD_MATCH = YES;
 				DEBUG_INFORMATION_FORMAT = "dwarf-with-dsym";
-				GCC_C_LANGUAGE_STANDARD = ansi;
+				GCC_C_LANGUAGE_STANDARD = c89;
 				GCC_OPTIMIZATION_LEVEL = s;
 				GCC_PREPROCESSOR_DEFINITIONS = CONFIG_VAR_HOT;
 				GCC_TREAT_IMPLICIT_FUNCTION_DECLARATIONS_AS_ERRORS = YES;
@@ -5775,7 +5809,24 @@
 				SDKROOT = macosx;
 				SYMROOT = xc;
 				WARNING_CFLAGS = (
-					"-std=c89\n-pedantic\n-Waggregate-return\n-Wall\n-Wcast-qual\n-Wconversion\n-Wduplicate-enum\n-Wextra\n-Winline\n-Wmissing-prototypes\n-Wmissing-variable-declarations\n-Wnested-externs\n-Wno-extended-offsetof\n-Wpointer-arith\n-Wshadow\n-Wstrict-aliasing=2\n-Wstrict-prototypes\n-Wunreachable-code\n-Wwrite-strings\n",
+					"-pedantic",
+					"-Waggregate-return",
+					"-Wall",
+					"-Wcast-qual",
+					"-Wconversion",
+					"-Wduplicate-enum",
+					"-Wextra",
+					"-Winline",
+					"-Wmissing-prototypes",
+					"-Wmissing-variable-declarations",
+					"-Wnested-externs",
+					"-Wno-extended-offsetof",
+					"-Wpointer-arith",
+					"-Wshadow",
+					"-Wstrict-aliasing=2",
+					"-Wstrict-prototypes",
+					"-Wunreachable-code",
+					"-Wwrite-strings",
 				);
 			};
 			name = Release;

From 460f12cd75e299480f5692ac6052b80486568a63 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Mon, 21 Mar 2016 10:42:21 +0000
Subject: [PATCH 43/69] Backing out accidental change to check.h.

Copied from Perforce
 Change: 190263
 ServerID: perforce.ravenbrook.com
---
 mps/code/check.h | 11 +----------
 1 file changed, 1 insertion(+), 10 deletions(-)

diff --git a/mps/code/check.h b/mps/code/check.h
index 2a08160040e..a2450bebd9a 100644
--- a/mps/code/check.h
+++ b/mps/code/check.h
@@ -39,15 +39,6 @@
 #include "mpslib.h"
 
 
-/* FIXME: to config.h? */
-
-#if defined(MPS_BUILD_LL) || defined(MPS_BUILD_GC)
-#define UNEXPECTED(expr)  __builtin_expect((expr) != 0, TRUE)
-#else
-#define UNEXPECTED(expr)  (expr)
-#endif
-
-
 /* ASSERT -- basic assertion
  *
  * The ASSERT macro is equivalent to the ISO C assert() except that it is
@@ -60,7 +51,7 @@
 
 #define ASSERT(cond, condstring) \
   BEGIN \
-    if (UNEXPECTED(cond)) NOOP; else                           \
+    if (cond) NOOP; else \
       mps_lib_assert_fail(MPS_FILE, __LINE__, (condstring)); \
   END
 

From 7a7913786c655b45c5e569715300cc33fa7dc1aa Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Tue, 22 Mar 2016 16:32:10 +0000
Subject: [PATCH 44/69] Responding to review by gdr
 <https://info.ravenbrook.com/mail/2016/03/21/20-20-15/0/>.

Copied from Perforce
 Change: 190307
 ServerID: perforce.ravenbrook.com
---
 mps/code/config.h                  |  2 +-
 mps/code/seg.c                     | 28 ++++++++++++++--------------
 mps/design/index.txt               |  3 +++
 mps/design/scan.txt                |  4 ++--
 mps/design/write-barrier.txt       |  6 +++---
 mps/manual/source/design/index.rst |  1 +
 6 files changed, 24 insertions(+), 20 deletions(-)

diff --git a/mps/code/config.h b/mps/code/config.h
index b7de3a7a227..a18f812c606 100644
--- a/mps/code/config.h
+++ b/mps/code/config.h
@@ -681,7 +681,7 @@
  * passed in the mutator rather than the number of scans.
  */
 
-#define WB_DEFER_BITS  3  /* bitfield width for deferral count */
+#define WB_DEFER_BITS  2  /* bitfield width for deferral count */
 #define WB_DEFER_INIT  3  /* boring scans after new segment */
 #define WB_DEFER_DELAY 3  /* boring scans after interesting scan */
 #define WB_DEFER_HIT   1  /* boring scans after barrier hit */
diff --git a/mps/code/seg.c b/mps/code/seg.c
index 7b11e8a8cf6..137388cc9fe 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -731,7 +731,7 @@ Bool SegCheck(Seg seg)
     /* write shielded. */
     /* CHECKL(seg->_summary == RefSetUNIV || (seg->_sm & AccessWRITE)); */
     /* @@@@ What can be checked about the read barrier? */
-    /* FIXME: Need gcSegCheck? CHECKL(seg->defer == 0 || seg->summary == RefSetUNIV); */
+    /* TODO: Need gcSegCheck?  What does RankSet imply about being a gcSeg? */
   }
   return TRUE;
 }
@@ -1313,6 +1313,16 @@ static void gcSegSetRankSet(Seg seg, RankSet rankSet)
 }
 
 
+static void gcSegSyncWriteBarrier(Seg seg, Arena arena)
+{
+  /* Can't check seg -- this function enforces invariants tested by SegCheck. */
+  if (SegSummary(seg) == RefSetUNIV)
+    ShieldLower(arena, seg, AccessWRITE);
+  else
+    ShieldRaise(arena, seg, AccessWRITE);
+}
+
+
 /* gcSegSetSummary -- GCSeg method to change the summary on a segment
  *
  * In fact, we only need to raise the write barrier if the
@@ -1337,12 +1347,7 @@ static void gcSegSetSummary(Seg seg, RefSet summary)
 
   AVER(seg->rankSet != RankSetEMPTY);
 
-  /* Note: !RefSetSuper is a test for a strict subset */
-  /* FIXME: Duplicate code with gcSegSetRankSummary. */
-  if (!RefSetSuper(summary, RefSetUNIV))
-    ShieldRaise(arena, seg, AccessWRITE);
-  else
-    ShieldLower(arena, seg, AccessWRITE);
+  gcSegSyncWriteBarrier(seg, arena);
 }
 
 
@@ -1369,13 +1374,8 @@ static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
   seg->rankSet = BS_BITFIELD(Rank, rankSet);
   gcseg->summary = summary;
 
-  if (rankSet != RankSetEMPTY) {
-    /* FIXME: Duplicate code with gcSegSetSummary. */
-    if (!RefSetSuper(summary, RefSetUNIV))
-      ShieldRaise(arena, seg, AccessWRITE);
-    else
-      ShieldLower(arena, seg, AccessWRITE);
-  }
+  if (rankSet != RankSetEMPTY)
+    gcSegSyncWriteBarrier(seg, arena);
 }
 
 
diff --git a/mps/design/index.txt b/mps/design/index.txt
index cde852448bb..7c889f1ee30 100644
--- a/mps/design/index.txt
+++ b/mps/design/index.txt
@@ -115,6 +115,7 @@ version_                Software versions
 vm_                     Virtual mapping
 vmo1_                   VM Module on DEC Unix
 vmso_                   VM Design for Solaris
+write-barrier_          Write Barrier
 writef_                 The WriteF function 
 ======================  ================================================
 
@@ -194,6 +195,7 @@ writef_                 The WriteF function
 .. _vm: vm
 .. _vmo1: vmo1
 .. _vmso: vmso
+.. _write-barrier: write-barrier
 .. _writef: writef
 
 
@@ -227,6 +229,7 @@ Document History
 - 2013-06-07	RB_	Converting to reST_.  Linking to [RB_2002-06-18]_.
 - 2014-01-29    RB_     The arena no longer manages generation zonesets.
 - 2014-01-17    GDR_    Add abq, nailboard, range.
+- 2016-03-22    RB_     Add write-barier.
 
 .. _RB: http://www.ravenbrook.com/consultants/rb
 .. _NB: http://www.ravenbrook.com/consultants/nb
diff --git a/mps/design/scan.txt b/mps/design/scan.txt
index 2b4c992d185..ef302553384 100644
--- a/mps/design/scan.txt
+++ b/mps/design/scan.txt
@@ -24,7 +24,7 @@ _`.summary.subset`: The summary of reference seens by scan
 
 There are two reasons that it is not an equality relation:
 
-#. If the segment has had objects forwarded onto it then its summary
+1. If the segment has had objects forwarded onto it then its summary
    will get unioned with the summary of the segment that the object
    was forwarded from. This may increase the summary. The forwarded
    object of course may have a smaller summary (if such a thing were
@@ -32,7 +32,7 @@ There are two reasons that it is not an equality relation:
    reduce the summary. (The forwarding process may erroneously
    introduce zones into the destination's summary).
 
-#. A write barrier hit will set the summary to ``RefSetUNIV``.
+2. A write barrier hit will set the summary to ``RefSetUNIV``.
 
 The reason that ``ss.unfixedSummary`` is always a subset of the
 previous summary is due to an "optimization" which has not been made
diff --git a/mps/design/write-barrier.txt b/mps/design/write-barrier.txt
index f2bd86c7e7d..3b54c882964 100644
--- a/mps/design/write-barrier.txt
+++ b/mps/design/write-barrier.txt
@@ -138,9 +138,9 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
-Ravenbrook for commercial licensing options.
+Copyright © 2016 Ravenbrook Limited <http://www.ravenbrook.com/>. All
+rights reserved.  This is an open source license. Contact Ravenbrook
+for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are
diff --git a/mps/manual/source/design/index.rst b/mps/manual/source/design/index.rst
index 1cea6c4861b..2513cc5e6ad 100644
--- a/mps/manual/source/design/index.rst
+++ b/mps/manual/source/design/index.rst
@@ -37,4 +37,5 @@ Design
     thread-manager
     type
     vm
+    write-barrier
     writef

From cf0ac842bc7373223725c4aa9562d65e9f341824 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 08:20:29 +0000
Subject: [PATCH 45/69] Reorganising shield design and updating.

Renaming ShieldSuspend to ShieldHold and ShieldResume to ShieldRelease to reduce confusion.

Copied from Perforce
 Change: 190320
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.h        |   8 +-
 mps/code/shield.c     |  12 +--
 mps/code/trace.c      |  10 +--
 mps/design/shield.txt | 184 ++++++++++++++++++++++++------------------
 4 files changed, 121 insertions(+), 93 deletions(-)

diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index ff64ccba362..5b03ee449e0 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -919,8 +919,8 @@ extern void (ShieldEnter)(Arena arena);
 extern void (ShieldLeave)(Arena arena);
 extern void (ShieldExpose)(Arena arena, Seg seg);
 extern void (ShieldCover)(Arena arena, Seg seg);
-extern void (ShieldSuspend)(Arena arena);
-extern void (ShieldResume)(Arena arena);
+extern void (ShieldHold)(Arena arena);
+extern void (ShieldRelease)(Arena arena);
 extern void (ShieldFlush)(Arena arena);
 
 #if defined(SHIELD)
@@ -936,8 +936,8 @@ extern void (ShieldFlush)(Arena arena);
   BEGIN UNUSED(arena); UNUSED(seg); END
 #define ShieldCover(arena, seg) \
   BEGIN UNUSED(arena); UNUSED(seg); END
-#define ShieldSuspend(arena) BEGIN UNUSED(arena); END
-#define ShieldResume(arena) BEGIN UNUSED(arena); END
+#define ShieldHold(arena) BEGIN UNUSED(arena); END
+#define ShieldRelease(arena) BEGIN UNUSED(arena); END
 #define ShieldFlush(arena) BEGIN UNUSED(arena); END
 #else
 #error "No shield configuration."
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 7eabf5f8986..164b7412819 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -161,7 +161,7 @@ static void shieldSync(Shield shield, Seg seg)
 }
 
 
-/* ShieldSuspend -- suspend the mutator
+/* ShieldHold -- suspend mutator access to the unprotectable
  *
  * From outside impl.c.shield, this is used when we really need to
  * lock everything against the mutator -- for example, during flip
@@ -171,7 +171,7 @@ static void shieldSync(Shield shield, Seg seg)
  * synced -- see .inv.unsynced.suspended.
  */
 
-void (ShieldSuspend)(Arena arena)
+void (ShieldHold)(Arena arena)
 {
   Shield shield;
   
@@ -186,13 +186,13 @@ void (ShieldSuspend)(Arena arena)
 }
 
 
-/* ShieldResume -- declare mutator could be resumed
+/* ShieldRelease -- declare mutator could be resumed
  *
  * In practice, we don't resume the mutator until ShieldLeave, but
  * this marks the earliest point at which we could resume.
  */
 
-void (ShieldResume)(Arena arena)
+void (ShieldRelease)(Arena arena)
 {
   Shield shield;
   
@@ -365,7 +365,7 @@ static void shieldQueue(Arena arena, Seg seg)
        segment, then raise the shield on it.  In this case, the
        mutator isn't allowed to see the segment, but we don't need to
        queue it until its covered. */
-    ShieldSuspend(arena);
+    ShieldHold(arena);
     return;
   }
 
@@ -625,7 +625,7 @@ void (ShieldExpose)(Arena arena, Seg seg)
   AVER_CRITICAL(shield->depth > 0); /* overflow */
   
   if (BS_INTER(SegPM(seg), mode) != AccessSetEMPTY)
-    ShieldSuspend(arena);
+    ShieldHold(arena);
 
   /* Ensure design.mps.shield.inv.expose.prot. */
   /* TODO: Mass exposure -- see
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 1f3db0d3467..e81ab41c869 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -573,7 +573,7 @@ static Res traceFlip(Trace trace)
 
   arena = trace->arena;
   rfc.arena = arena;
-  ShieldSuspend(arena);
+  ShieldHold(arena);
 
   AVER(trace->state == TraceUNFLIPPED);
   AVER(!TraceSetIsMember(arena->flippedTraces, trace));
@@ -634,11 +634,11 @@ static Res traceFlip(Trace trace)
 
   EVENT2(TraceFlipEnd, trace, arena);
 
-  ShieldResume(arena);
+  ShieldRelease(arena);
   return ResOK;
 
 failRootFlip:
-  ShieldResume(arena);
+  ShieldRelease(arena);
   return res;
 }
 
@@ -737,8 +737,8 @@ Res TraceCreate(Trace *traceReturn, Arena arena, int why)
   /* buffers under our feet. */
   /* @@@@ This is a short-term fix for request.dylan.160098_. */
   /* .. _request.dylan.160098: https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/dylan/160098 */
-  /* TODO: Where is the corresponding ShieldResume? */
-  ShieldSuspend(arena);
+  /* TODO: Where is the corresponding ShieldRelease? */
+  ShieldHold(arena);
 
   STATISTIC_STAT ({
     /* Iterate over all chains, all GenDescs within a chain, and all
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 03a3c2a1c31..52011a28ca0 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -9,7 +9,7 @@ Shield
 :Status: incomplete guide
 :Revision: $Id$
 :Copyright: See `Copyright and License`_.
-:Index terms:    pair: shield; design
+:Index terms: pair: shield; design
 
 
 Introduction
@@ -25,8 +25,10 @@ _`.readership`: Any MPS developer. Not confidential.
 Overview
 --------
 
-_`.over`: For incremental collection, we need *separate control* of
-collector access and mutator (client) access to memory. The collector
+_`.overview`: The MPS implements incremental garbage collection using
+memory barriers implemented by a combination of hardware memory
+protection and thread control.  The MPS needs *separate control* of
+collector access and mutator (client) access to memory: the collector
 must be able to incrementally scan objects, without the mutator being
 able to see them yet.
 
@@ -38,99 +40,123 @@ limitation, and give the rest of the MPS the illusion that we can
 control collector and mutator access separately.
 
 
-Control of mutator access
--------------------------
+Interface
+---------
 
-The MPS uses ``ShieldRaise()`` and ``ShieldLower()`` to forbid or
-permit the mutator access to object memory (that is, memory allocated
-by MPS).
+
+Mutator access
+..............
+
+The shield provides ``ShieldRaise`` and ``ShieldLower`` to forbid or
+permit the mutator access to object memory segments.  Between these
+two, a segment is said to have the shield "raised".
 
 ``void ShieldRaise(Arena arena, Seg seg, AccessSet mode)``
 
-    Prevent the mutator accessing the memory in the specified mode
-    (``AccessREAD``, ``AccessWRITE``, or both).
+    Prevent the mutator accessing the memory segment in the specified
+    mode (``AccessREAD``, ``AccessWRITE``, or both).
 
 ``void ShieldLower(Arena arena, Seg seg, AccessSet mode)``
 
-    Allow the mutator to access the memory in the specified mode
-    (``AccessREAD``, ``AccessWRITE``, or both).
+    Allow the mutator to access the memory segment in the specified
+    mode (``AccessREAD``, ``AccessWRITE``, or both).
 
-If the mutator attempts an access that hits a shield, the MPS gets a
-barrier hit (in the form of a fault, interrupt, exception), quickly
-does some necessary work, and then makes the access succeed.
+If the mutator attempts an access that hits the shield, the MPS gets
+an OS-specific hardware protection fault which reaches
+``ArenaAccess``, does whatever work is necessary, then lowers the
+shield and returns to the mutator.
 
-Some objects (for example registers) cannot be hardware protected: the
-only way to prevent mutator access to them is to halt all mutator
-threads. The MPS uses ``ShieldSuspend()`` and ``ShieldResume()`` to do
-this.
-
-``void ShieldSuspend(Arena arena)``
-
-    Stop all registered mutator threads.
-
-``void ShieldResume(Arena arena)``
-
-    Resume all registered mutator threads.
+``ShieldRaise`` and ``ShieldLower` do *not* nest.
 
 
-Control of collector access
----------------------------
+Entering the shield
+...................
 
-When the collector wants to access object memory (that is, memory
-allocated by MPS), it must first call ``ShieldEnter()``, then wrap any
-accesses with a ``ShieldExpose()`` and ``ShieldCover()`` pair, and
-finally call ``ShieldLeave()``.
+The MPS can only gain exclusive access from "inside" the shield.  To
+enter the shield, the MPS must call ``ShieldEnter``, and to leave it,
+the MPS must call ``ShieldLeave``.
 
-``ShieldEnter()`` and ``ShieldLeave()`` are called by ``ArenaEnter()``
-and ``ArenaLeave()`` (approximately) -- so the shield is always
-entered when we are within MPS code (approximately).
+``ShieldEnter`` and ``ShieldLeave`` are called by ``ArenaEnter`` and
+``ArenaLeave`` so almost all of the MPS is is "inside" the shield.
 
-``ShieldExpose()`` might for example be called around:
 
-- format-scan (when scanning);
-- format-skip (when marking grains in a non-moving fix);
-- format-isMoved and ``AddrCopy()`` (during a copying fix);
-- format-pad (during reclaim).
+Collector access to aegments
+----------------------------
 
-Note that there is no need to call ``ShieldExpose()`` when accessing
-pool management memory such as bit tables. This is not object
-memory, is never (legally) accessed by the mutator, and so is never
-shielded.
+When the MPS wants to access object memory segments from inside the
+shield, it must wrap any accesses with a ``ShieldExpose`` and
+``ShieldCover`` pair.  Between calls to ``ShieldExpose`` and
+``ShieldCover``, a segment is said to be "exposed".
 
-On common operating systems, the only way to allow collector access is
-to allow access from the whole process, including the mutator. So if
-the Shield is asked to allow collector access but deny mutator access,
-it will halt all mutator threads to prevent any mutator access. The
-Shield performs suspension and restart; normal collector code does not
-need to worry about it.
+A segment might for example be exposed during:
 
-Collector code can make multiple sequential, overlapping, or nested
-calls to ``ShieldExpose()`` on the same segment, as long as each is
-balanced by a corresponding ``ShieldCover()`` before ``ShieldLeave()``
-is called). A usage count is maintained on each segment in
-``seg->depth``: a positive "depth" means a positive number of
-outstanding *reasons* why the segment must be exposed to the collector.
-When the usage count reaches zero, there is no longer any reason the
-segment should be unprotected, and the Shield could re-instate
-hardware protection.
+  - format-scan (when scanning);
+  - format-skip (when marking grains in a non-moving fix);
+  - format-isMoved and ``AddrCopy`` (during a copying fix);
+  - format-pad (during reclaim).
 
-However, as a performance-improving hysteresis, the Shield defers
-re-protection, maintaining a queue of segments that no longer have a
-reason to be collector-accessible.  While a segment is in the queue,
-it has ``seg->queued`` set to TRUE.
+Note that there is no need to call ``ShieldExpose`` when accessing
+pool management memory such as bit tables. This is not object memory,
+is never (legally) accessed by the mutator, and so is never shielded.
+
+Similarly, a pool class that never raises the shield on its segments
+need never expose them to gain access.
+
+
+Collector access to the unprotectable
+.....................................
+
+Then the MPS wants to access an unprotectable object from inside the
+shield, it must wrap any accesses with a ``ShieldHold`` and
+``ShieldRelease`` pair.  This allows access to objects which cannot be
+shielded by ``ShieldRaise``, such as:
+
+  - the stack and registers of mutator threads,
+  - lockless allocation point structures,
+  - areas of memory that can't be protected by operating system calls,
+  - unprotectable roots.
+
+``void ShieldHold(Arena arena)``
+
+    Get exclusive access to the unprotectable.
+
+``void ShieldRelease(Arena arena)``
+
+    Declare that exclusive access is no longer needed.
+
+
+Mechanism
+---------
+
+On common operating systems, the only way to allow the MPS access is
+to allow access from the whole process, including the mutator. So
+``ShieldExpose`` will suspend all mutator threads to prevent any mutator
+access, and so will ``ShieldRaise`` on an unexposed segment. The
+shield handles suspending and resuming threads, and the the rest of
+the MPS does not need to worry about it.
+
+The MPS can make multiple sequential, overlapping, or nested calls to
+``ShieldExpose`` on the same segment, as long as each is balanced by a
+corresponding ``ShieldCover`` before ``ShieldLeave`` is called. A
+usage count is maintained on each segment in ``seg->depth``.  When the
+usage count reaches zero, there is no longer any reason the segment
+should be unprotected, and the shield may reinstate hardware
+protection at any time.
+
+.impl.delay: However, as a performance-improving hysteresis, the
+shield defers re-protection, maintaining a queue of segments that
+require attention before mutator threads are resumed.  While a segment
+is in the queue, it has ``seg->queued`` set to TRUE.
 
 This hysteresis allows the MPS to proceed with garbage collection
 during a pause without actually setting hardware protection until it
-returns to the mutator.  If a complete collection cycle occurs during
-one pause (a non-incremental collection), no system calls will be
-needed for collection barriers.  This is particularly important on
-operating systems where the protection is expensive and poorly
-implemented, such as OS X.
+returns to the mutator. This is particularly important on operating
+systems where the protection is expensive and poorly implemented, such
+as OS X.
 
-So whenever hardware protection is temporarily removed to allow
-collector access, there is a *nurse* that will ensure this protection
-is re-established: the nurse is either the balancing ``ShieldCover()``
-call in collector code, or an entry in the shield queue.
+The queue also ensures that no memory protection system calls will be
+neededIf a complete collection cycle occurs during one pause, allowing
+the MPS to operate in a non-incremental mode.
 
 
 Implementation
@@ -170,9 +196,11 @@ inside the shield is being between calls to ``ShieldEnter`` and
 ``ShieldLeave``.  [In a multi-threaded MPS this would be per-thread.
 RB 2016-03-18]
 
-.def.suspended: Suspended is true iff the mutator is suspended.
+.def.suspended: Suspended is true iff the mutator is
+suspended. [Between calls to ThreadSuspend and ThreadResume?]
 
-.def.shielded: A segment is shielded if the shield mode is non-zero.
+.def.shielded: A segment is shielded if the shield mode is
+non-zero. [As set by ShieldRaise.]
 
 
 Properties
@@ -182,9 +210,9 @@ Properties
 the shield.
 
 .prop.mutator.access: An attempt by the mutator to access shielded
-memory must cause an ArenaAccess.
+memory be pre-empted by a call to ``ArenaAccess``.
 
-.prop.inside.access: Inside the shield it must be possible to access
+.prop.inside.access: Inside the shield the MPS must be able to access
 all unshielded segments and all exposed segments.
 
 
@@ -272,7 +300,7 @@ Concurrent collection
 however the only thing that makes it not-concurrent is a critical
 point in the Shield abstraction where the MPS seeks to gain privileged
 access to memory (usually in order to scan it for GC). The critical
-point is where ShieldExpose in shield.c has to call ShieldSuspend to
+point is where ShieldExpose in shield.c has to call ShieldHold to
 preserve the shield invariants. This is the only point in the MPS that
 prevents concurrency, and the rest of the MPS is designed to support
 it.

From 5bc87114eacbd4e21e387a3a1712f58cf9e706c3 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 11:59:57 +0000
Subject: [PATCH 46/69] Counting shield holds and releases, to ensure they are
 nested correctly.

Counting the number of unsynced segments in order to check consistency.
Moving the extra shield hold for request.dylan.160098 around actual whitening, and adding a matching shield release.

Copied from Perforce
 Change: 190321
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpmst.h  |   2 +
 mps/code/shield.c | 161 +++++++++++++++++++++++++++++++++++++---------
 mps/code/trace.c  |  19 +++---
 3 files changed, 142 insertions(+), 40 deletions(-)

diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 64ddd12b202..ea8d8bd00bd 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -692,6 +692,8 @@ typedef struct ShieldStruct {
   Index next;        /* next free element in shield queue */
   Index limit;       /* high water mark for cache usage */
   Count depth;       /* sum of depths of all segs */
+  Count unsynced;    /* number of unsynced segments */
+  Count holds;       /* number of holds */
   Bool suspended;    /* mutator suspended? */
 } ShieldStruct;
 
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 164b7412819..307c8d89606 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -23,6 +23,8 @@ void ShieldInit(Shield shield)
   shield->next = 0;
   shield->limit = 0;
   shield->depth = 0;
+  shield->unsynced = 0;
+  shield->holds = 0;
   shield->suspended = FALSE;
   shield->sig = ShieldSig;
 }
@@ -44,10 +46,15 @@ void ShieldDestroyQueue(Shield shield, Arena arena)
 
 void ShieldFinish(Shield shield)
 {
+  AVER(shield->depth == 0);
+  AVER(shield->unsynced == 0);
+  AVER(shield->holds == 0);
   shield->sig = SigInvalid;
 }
 
 
+static Bool SegIsSynced(Seg seg);
+
 Bool ShieldCheck(Shield shield)
 {
   CHECKS(Shield, shield);
@@ -63,25 +70,42 @@ Bool ShieldCheck(Shield shield)
 
   /* If any segment is not synced, the mutator is suspended
      (design.mps.shield.inv.unsynced.suspended). */
+  CHECKL(shield->unsynced == 0 || shield->suspended);
+
+  /* If any segment is exposed, the mutator is suspended. */
   CHECKL(shield->depth == 0 || shield->suspended);
 
   /* The total depth is zero while outside the shield
      (design.mps.shield.inv.outside.depth). */
   CHECKL(shield->inside || shield->depth == 0);
 
+  /* There are no unsynced segments when we're outside the shield. */
+  CHECKL(shield->inside || shield->unsynced == 0);
+
+  /* Every unsynced segment should be on the queue, because we have to
+     remember to sync it before we return to the mutator. */
+  CHECKL(shield->limit >= shield->unsynced);
+
+  /* The mutator is suspeneded if there are any holds. */
+  CHECKL(shield->holds == 0 || shield->suspended);
+
   /* This is too expensive to check all the time since we have an
      expanding shield queue that often has 16K elements instead of
      16. */
 #if defined(AVER_AND_CHECK_ALL)
   {
     Count depth = 0;
+    Count unsynced = 0;
     Index i;
     for (i = 0; i < shield->limit; ++i) {
       Seg seg = shield->queue[i];
       CHECKD(Seg, seg);
       depth += SegDepth(seg);
+      if (!SegIsSynced(seg))
+        ++unsynced;
     }
     CHECKL(depth == shield->depth);
+    CHECKL(unsynced == shield->unsynced);
   }
 #endif
 
@@ -94,11 +118,15 @@ Res ShieldDescribe(Shield shield, mps_lib_FILE *stream, Count depth)
   Res res;
   
   res = WriteF(stream, depth,
-               shield->inside ? "inside" : "outside", " shield\n",
-               "suspended $S\n", WriteFYesNo(shield->suspended),
-               "shield depth $U\n", (WriteFU)shield->depth,
-               "shield next $U\n", (WriteFU)shield->next,
-               "shield length $U\n", (WriteFU)shield->length,
+               "Shield $P {\n",    (WriteFP)shield,
+               "  ", shield->inside ? "inside" : "outside", " shield\n",
+               "  suspended $S\n", WriteFYesNo(shield->suspended),
+               "  depth     $U\n", (WriteFU)shield->depth,
+               "  next      $U\n", (WriteFU)shield->next,
+               "  length    $U\n", (WriteFU)shield->length,
+               "  unsynced  $U\n", (WriteFU)shield->unsynced,
+               "  holds     $U\n", (WriteFU)shield->holds,
+               "} Shield $P\n",    (WriteFP)shield,
                NULL);
   if (res != ResOK)
     return res;
@@ -132,6 +160,44 @@ static Bool SegIsSynced(Seg seg)
 }
 
 
+/* shieldSetSM -- set shield mode, maintaining sync count */
+
+static void shieldSetSM(Shield shield, Seg seg, AccessSet mode)
+{
+  if (SegSM(seg) != mode) {
+    if (SegIsSynced(seg)) {
+      SegSetSM(seg, mode);
+      ++shield->unsynced;
+    } else {
+      SegSetSM(seg, mode);
+      if (SegIsSynced(seg)) {
+        AVER(shield->unsynced > 0);
+        --shield->unsynced;
+      }
+    }
+  }
+}
+
+
+/* shieldSetPM -- set protection mode, maintaining sync count */
+
+static void shieldSetPM(Shield shield, Seg seg, AccessSet mode)
+{
+  if (SegPM(seg) != mode) {
+    if (SegIsSynced(seg)) {
+      SegSetPM(seg, mode);
+      ++shield->unsynced;
+    } else {
+      SegSetPM(seg, mode);
+      if (SegIsSynced(seg)) {
+        AVER(shield->unsynced > 0);
+        --shield->unsynced;
+      }
+    }
+  }
+}  
+
+
 /* SegIsExposed -- is a segment exposed?
  *
  * See design.mps.shield.def.exposed.
@@ -151,27 +217,23 @@ static Bool SegIsExposed(Seg seg)
 
 static void shieldSync(Shield shield, Seg seg)
 {
-  UNUSED(shield);
   SHIELD_AVERT_CRITICAL(Seg, seg);
 
   if (!SegIsSynced(seg)) {
     ProtSet(SegBase(seg), SegLimit(seg), SegSM(seg));
-    SegSetPM(seg, SegSM(seg));
+    shieldSetPM(shield, seg, SegSM(seg));
   }
 }
 
 
-/* ShieldHold -- suspend mutator access to the unprotectable
+/* shieldSUspend -- suspend the mutator
  *
- * From outside impl.c.shield, this is used when we really need to
- * lock everything against the mutator -- for example, during flip
- * when we must scan all thread registers at once.
- *
- * It is called from inside impl.c.shield when any segment is not
- * synced -- see .inv.unsynced.suspended.
+ * Called from inside impl.c.shield when any segment is not synced, in
+ * order to provide exclusive access to the segment by the MPS.  See
+ * .inv.unsynced.suspended.
  */
 
-void (ShieldHold)(Arena arena)
+static void shieldSuspend(Arena arena)
 {
   Shield shield;
   
@@ -186,6 +248,21 @@ void (ShieldHold)(Arena arena)
 }
 
 
+/* ShieldHold -- suspend mutator access to the unprotectable
+ *
+ * From outside impl.c.shield, this is used when we really need to
+ * lock everything against the mutator -- for example, during flip
+ * when we must scan all thread registers at once.
+ */
+
+void (ShieldHold)(Arena arena)
+{
+  AVERT(Arena, arena);
+  shieldSuspend(arena);
+  ++ArenaShield(arena)->holds;
+}
+
+
 /* ShieldRelease -- declare mutator could be resumed
  *
  * In practice, we don't resume the mutator until ShieldLeave, but
@@ -201,8 +278,12 @@ void (ShieldRelease)(Arena arena)
   AVER(shield->inside);
   AVER(shield->suspended);
 
+  AVER(shield->holds > 0);
+  --shield->holds;
+
   /* It is only correct to actually resume the mutator here if
-     shield->depth is 0 and the queue is empty. */
+     shield->depth is 0, shield->unsycned is 0, and the queue is
+     empty. */
   /* TODO: Consider actually doing that. */
 }
 
@@ -212,14 +293,14 @@ void (ShieldRelease)(Arena arena)
  * This ensures actual prot mode does not include mode.
  */
 
-static void shieldProtLower(Seg seg, AccessSet mode)
+static void shieldProtLower(Shield shield, Seg seg, AccessSet mode)
 {
   /* <design/trace/#fix.noaver> */
   SHIELD_AVERT_CRITICAL(Seg, seg);
   AVERT_CRITICAL(AccessSet, mode);
 
   if (BS_INTER(SegPM(seg), mode) != AccessSetEMPTY) {
-    SegSetPM(seg, BS_DIFF(SegPM(seg), mode));
+    shieldSetPM(shield, seg, BS_DIFF(SegPM(seg), mode));
     ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg));
   }
 }
@@ -240,7 +321,14 @@ static Seg shieldDequeue(Shield shield, Index i)
 }
 
 
-/* shieldFlushEntry -- flush a single entry from the queue */
+/* shieldFlushEntry -- flush a single entry from the queue
+ *
+ * If the segment is exposed we can simply dequeue it, because later
+ * there will be a call to ShieldCover that will put it back on the
+ * queue.  If the segment is not exposed, we can sync its protection.
+ * (And if it does not have the shield raised any more, that will do
+ * nothing.)
+ */
 
 static void shieldFlushEntry(Shield shield, Index i)
 {
@@ -256,6 +344,7 @@ static void shieldFlushEntry(Shield shield, Index i)
 static void shieldQueueReset(Shield shield)
 {
   AVER(shield->depth == 0); /* overkill: implies no segs are queued */
+  AVER(shield->unsynced == 0);
   shield->next = 0;
   shield->limit = 0;
 }
@@ -319,7 +408,7 @@ static void shieldFlushEntries(Shield shield)
     Seg seg = shieldDequeue(shield, i);
     if (!SegIsSynced(seg)) {
       AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
-      SegSetPM(seg, SegSM(seg));
+      shieldSetPM(shield, seg, SegSM(seg));
       if (SegSM(seg) != mode || SegBase(seg) != limit) {
         if (mode != AccessSetEMPTY) {
           AVER(base != NULL);
@@ -365,7 +454,7 @@ static void shieldQueue(Arena arena, Seg seg)
        segment, then raise the shield on it.  In this case, the
        mutator isn't allowed to see the segment, but we don't need to
        queue it until its covered. */
-    ShieldHold(arena);
+    shieldSuspend(arena);
     return;
   }
 
@@ -444,16 +533,18 @@ static void shieldQueue(Arena arena, Seg seg)
 
 void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
 {
-  
   SHIELD_AVERT(Arena, arena);
   SHIELD_AVERT(Seg, seg);
-
   AVERT(AccessSet, mode);
-  AVER((SegSM(seg) & mode) == AccessSetEMPTY);
-  
-  SegSetSM(seg, SegSM(seg) | mode); /* .inv.prot.shield preserved */
 
-  /* ensure .inv.unsynced.suspended and .inv.unsynced.depth */
+  /* ShieldRaise does not nest. */
+  AVER(BS_INTER(SegSM(seg), mode) == AccessSetEMPTY);
+
+  /* design.mps.shield.inv.prot.shield preserved */
+  shieldSetSM(ArenaShield(arena), seg, BS_UNION(SegSM(seg), mode));
+  
+  /* Ensure design.mps.shield.inv.unsynced.suspended and
+     design.mps.shield.inv.unsynced.depth */
   shieldQueue(arena, seg);
 
   /* Check queue and segment consistency. */
@@ -466,19 +557,22 @@ void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
 
 void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
 {
+  Shield shield;
+  
   AVERT(Arena, arena);
+  shield = ArenaShield(arena);
   SHIELD_AVERT(Seg, seg);
   AVERT(AccessSet, mode);
   AVER(BS_INTER(SegSM(seg), mode) == mode);
-  
+
   /* SegIsSynced(seg) is not changed by the following preserving
      design.mps.shield.inv.unsynced.suspended and
      design.mps.shield.inv.prot.shield. */
-  SegSetSM(seg, BS_DIFF(SegSM(seg), mode));
+  shieldSetSM(shield, seg, BS_DIFF(SegSM(seg), mode));
   /* TODO: Do we need to promptly call shieldProtLower here?  It
      loses the opportunity to coalesce the protection call. It would
      violate design.mps.shield.prop.inside.access. */
-  shieldProtLower(seg, mode);
+  shieldProtLower(shield, seg, mode);
 
   /* Check queue and segment consistency. */
   AVERT(Arena, arena);
@@ -588,9 +682,12 @@ void (ShieldLeave)(Arena arena)
   shield = ArenaShield(arena);
   AVER(shield->inside);
   AVER(shield->depth == 0); /* no pending covers */
+  AVER(shield->holds == 0);
 
   ShieldFlush(arena);
 
+  AVER(shield->unsynced == 0); /* everything back in sync */
+
   /* Ensuring the mutator is running at this point guarantees
      .inv.outside.running */
   if (shield->suspended) {
@@ -625,12 +722,12 @@ void (ShieldExpose)(Arena arena, Seg seg)
   AVER_CRITICAL(shield->depth > 0); /* overflow */
   
   if (BS_INTER(SegPM(seg), mode) != AccessSetEMPTY)
-    ShieldHold(arena);
+    shieldSuspend(arena);
 
   /* Ensure design.mps.shield.inv.expose.prot. */
   /* TODO: Mass exposure -- see
      design.mps.shield.improv.mass-expose. */
-  shieldProtLower(seg, mode);
+  shieldProtLower(shield, seg, mode);
 }
 
 
diff --git a/mps/code/trace.c b/mps/code/trace.c
index e81ab41c869..148db0166bf 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -732,14 +732,6 @@ Res TraceCreate(Trace *traceReturn, Arena arena, int why)
 
   EVENT3(TraceCreate, trace, arena, (EventFU)why);
 
-  /* We suspend the mutator threads so that the PoolWhiten methods */
-  /* can calculate white sets without the mutator allocating in */
-  /* buffers under our feet. */
-  /* @@@@ This is a short-term fix for request.dylan.160098_. */
-  /* .. _request.dylan.160098: https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/dylan/160098 */
-  /* TODO: Where is the corresponding ShieldRelease? */
-  ShieldHold(arena);
-
   STATISTIC_STAT ({
     /* Iterate over all chains, all GenDescs within a chain, and all
      * PoolGens within a GenDesc. */
@@ -1491,6 +1483,14 @@ static Res traceCondemnAll(Trace trace)
   arena = trace->arena;
   AVERT(Arena, arena);
 
+  /* We suspend the mutator threads so that the PoolWhiten methods */
+  /* can calculate white sets without the mutator allocating in */
+  /* buffers under our feet. */
+  /* @@@@ This is a short-term fix for request.dylan.160098_. */
+  /* .. _request.dylan.160098: https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/dylan/160098 */
+  /* TODO: Where is the corresponding ShieldRelease? */
+  ShieldHold(arena);
+
   /* Condemn all segments in pools with the GC attribute. */
   RING_FOR(poolNode, &ArenaGlobals(arena)->poolRing, nextPoolNode) {
     Pool pool = RING_ELT(Pool, arenaRing, poolNode);
@@ -1509,6 +1509,8 @@ static Res traceCondemnAll(Trace trace)
     }
   }
 
+  ShieldRelease(arena);
+
   if (TraceIsEmpty(trace))
     return ResFAIL;
 
@@ -1529,6 +1531,7 @@ static Res traceCondemnAll(Trace trace)
    * will be triggered. In that case, we'll have to recover here by
    * blackening the segments again. */
   AVER(TraceIsEmpty(trace));
+  ShieldRelease(arena);
   return res;
 }
 

From c69b78c3dbc3e21e62cd92a0a5ae254046e2e9ae Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 12:55:07 +0000
Subject: [PATCH 47/69] Clarifying definition of "exposed".

Copied from Perforce
 Change: 190326
 ServerID: perforce.ravenbrook.com
---
 mps/design/shield.txt | 34 +++++++++++++++++++++-------------
 1 file changed, 21 insertions(+), 13 deletions(-)

diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 52011a28ca0..72068789c28 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -49,7 +49,7 @@ Mutator access
 
 The shield provides ``ShieldRaise`` and ``ShieldLower`` to forbid or
 permit the mutator access to object memory segments.  Between these
-two, a segment is said to have the shield "raised".
+two, a segment is said to have the shield "raised" (.def.raised).
 
 ``void ShieldRaise(Arena arena, Seg seg, AccessSet mode)``
 
@@ -66,15 +66,15 @@ an OS-specific hardware protection fault which reaches
 ``ArenaAccess``, does whatever work is necessary, then lowers the
 shield and returns to the mutator.
 
-``ShieldRaise`` and ``ShieldLower` do *not* nest.
+``ShieldRaise`` and ``ShieldLower`` do *not* nest.
 
 
 Entering the shield
 ...................
 
-The MPS can only gain exclusive access from "inside" the shield.  To
-enter the shield, the MPS must call ``ShieldEnter``, and to leave it,
-the MPS must call ``ShieldLeave``.
+The MPS can only gain exclusive access from "inside" the shield
+(.def.inside).  To enter the shield, the MPS must call
+``ShieldEnter``, and to leave it, the MPS must call ``ShieldLeave``.
 
 ``ShieldEnter`` and ``ShieldLeave`` are called by ``ArenaEnter`` and
 ``ArenaLeave`` so almost all of the MPS is is "inside" the shield.
@@ -85,8 +85,10 @@ Collector access to aegments
 
 When the MPS wants to access object memory segments from inside the
 shield, it must wrap any accesses with a ``ShieldExpose`` and
-``ShieldCover`` pair.  Between calls to ``ShieldExpose`` and
-``ShieldCover``, a segment is said to be "exposed".
+``ShieldCover`` pair.  These calls nest.  After a call to
+``ShieldExpose`` a segment is said to be "exposed" until the last
+nested call to ``ShieldCover``.  The shield arranges that the MPS can
+access the memory while it is exposed.
 
 A segment might for example be exposed during:
 
@@ -164,15 +166,19 @@ Implementation
 
 .impl.delay: The implementation of the shield avoids suspending
 threads for as long as possible.  When threads are suspended, it
-maintains a queue of covered segments where the desired and actual
-protection do not match.  This queue is flushed on leaving the shield.
+maintains a queue of segments where the desired and actual protection
+do not match.  This queue is flushed on leaving the shield.
 
 
 Definitions
 ...........
 
-.def.exposed: A seg is exposed if the prot mode is a subset of the
-shield mode, and covered otherwise.
+.def.raised: A segment has the shield "raised" for an access mode
+after a call to ``ShieldRaise`` and before a call to ``ShieldLower``
+with that mode.
+
+.def.exposed: A segment is "exposed" after a call to ``ShieldExpose``
+and before a call to ``ShieldLower``.
 
 .def.synced: A seg is synced if the prot and shield modes are the
 same, and unsynced otherwise.
@@ -180,8 +186,8 @@ same, and unsynced otherwise.
 .def.depth: The depth of a segment is defined as:
 
   | depth ≔ #exposes − #covers, where
-  |    #exposes = the total number of times the seg has been exposed
-  |    #covers  = the total number of times the seg has been covered
+  |    #exposes = the number of calls to ``ShieldExpose`` on the seg
+  |    #covers  = the number of calls to ``ShieldCover`` on the seg
 
 The queue is initially empty and ``ShieldCover`` should not be called
 without a matching ``ShieldExpose``, so this figure should always be
@@ -232,6 +238,8 @@ in the queue.
 
 .inv.prot.shield: The prot mode is never more than the shield mode.
 
+.inv.expose.depth: An exposed seg's depth is greater than zero.
+
 .inv.expose.prot: An exposed seg is not protected in the mode it was
 exposed with.
 

From f8a79ec8e44f3e4535536e72ab449e65ed3a6e8c Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 13:11:19 +0000
Subject: [PATCH 48/69] Added discussion of when it might be good to resume the
 mutator early in design.mps.shield.improv.resume.

Copied from Perforce
 Change: 190329
 ServerID: perforce.ravenbrook.com
---
 mps/code/seg.c        |  4 +++-
 mps/code/shield.c     |  8 ++++----
 mps/design/shield.txt | 18 +++++++++++++++---
 3 files changed, 22 insertions(+), 8 deletions(-)

diff --git a/mps/code/seg.c b/mps/code/seg.c
index 64fb86c2d28..e7c43c31ddf 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -714,11 +714,13 @@ Bool SegCheck(Seg seg)
   /*  CHECKL(RingNext(&seg->poolRing) != &seg->poolRing); */
 
   CHECKD_NOSIG(Ring, &seg->poolRing);
+
+  /* Shield invariants -- see design.mps.shield. */
    
   /* The protection mode is never more than the shield mode
      (design.mps.shield.inv.prot.shield). */
   CHECKL(BS_DIFF(seg->pm, seg->sm) == 0);
-  
+
   /* All unsynced segments have positive depth or are in the queue
      (design.mps.shield.inv.unsynced.depth). */
   CHECKL(seg->sm == seg->pm || seg->depth > 0 || seg->queued);
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 307c8d89606..5245d2a9177 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -284,7 +284,8 @@ void (ShieldRelease)(Arena arena)
   /* It is only correct to actually resume the mutator here if
      shield->depth is 0, shield->unsycned is 0, and the queue is
      empty. */
-  /* TODO: Consider actually doing that. */
+  /* See design.mps.shield.improv.resume for a discussion of when it
+     might be a good idea to resume the mutator early. */
 }
 
 
@@ -618,7 +619,7 @@ static void shieldDebugCheck(Arena arena)
   Count queued = 0;
 
   AVERT(Arena, arena);
-  shield = ShieldArena(arena);
+  shield = ArenaShield(arena);
   AVER(shield->inside || shield->limit == 0);
 
   if (SegFirst(&seg, arena))
@@ -664,8 +665,7 @@ void (ShieldFlush)(Arena arena)
   shieldDebugCheck(arena);
 #endif
   shieldFlushEntries(shield);
-  /* Queue is empty so .inv.outside.depth holds */
-  AVER(shield->depth == 0);
+  AVER(shield->unsynced == 0); /* everything back in sync */
 #ifdef SHIELD_DEBUG
   shieldDebugCheck(arena);
 #endif
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 72068789c28..a93736f8a16 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -189,9 +189,8 @@ same, and unsynced otherwise.
   |    #exposes = the number of calls to ``ShieldExpose`` on the seg
   |    #covers  = the number of calls to ``ShieldCover`` on the seg
 
-The queue is initially empty and ``ShieldCover`` should not be called
-without a matching ``ShieldExpose``, so this figure should always be
-non-negative.
+``ShieldCover`` should not be called without a matching
+``ShieldExpose``, so this figure should always be non-negative.
 
 .def.total.depth: The total depth is the sum of the depth over all
 segments.
@@ -330,6 +329,19 @@ MPS design. It's kind of waiting to happen.
 (Originally written at <http://news.ycombinator.com/item?id=4524036>.)
 
 
+Early Resume
+............
+
+.improv.resume: There is a tradeoff between delaying flushing the
+shield queue (preventing unnecessary protection and allowing us to
+coalesce) and resuming mutator threads.  We could resume threads
+earlier under some circumstances, such as before reclaim (which does
+not need to interact with the mutator).  Basically, it might be worth
+resuming the mutator early in a pause if we know that we're unlikely
+to suspend it again (no more calls to ``ShieldRaise`` or
+``ShieldExpose`` on shielded segments).
+
+
 References
 ----------
 

From 4204f99d6705148a2ce1a2cfcff3374df59eb934 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 13:47:55 +0000
Subject: [PATCH 49/69] Moving quicksort's workspace off the stack to limit mps
 stack usage.

Copied from Perforce
 Change: 190332
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.c    | 31 ++++++++++++++++++-------------
 mps/code/mpm.h    |  3 ++-
 mps/code/mpmst.h  | 15 +++++++++++++++
 mps/code/shield.c |  3 ++-
 4 files changed, 37 insertions(+), 15 deletions(-)

diff --git a/mps/code/mpm.c b/mps/code/mpm.c
index f2ea2acb27a..56b5c3973c8 100644
--- a/mps/code/mpm.c
+++ b/mps/code/mpm.c
@@ -9,6 +9,7 @@
  * .sources: <design/writef/> */
 
 #include "check.h"
+#include "misc.h"
 #include "mpm.h"
 #include "vm.h"
 
@@ -699,20 +700,24 @@ static Bool quickSorted(void *array[], Count length,
 #endif
 
 void QuickSort(void *array[], Count length,
-               QuickSortCompare compare, void *closure)
+               QuickSortCompare compare, void *closure,
+	       SortStruct *sortStruct)
 {
-  struct {
-    Index left, right;
-  } stack[MPS_WORD_WIDTH];
   Index left, right, sp, lo, hi, leftLimit, rightBase;
   void *pivot, *temp;
 
+  AVER(array != NULL);
+  /* can't check length */
+  AVER(FUNCHECK(compare));
+  /* can't check closure */
+  AVER(sortStruct != NULL);
+
   sp = 0;
   left = 0;
   right = length;
 
   for (;;) {
-    while (right - left > 1) { /* no need to sort */
+    while (right - left > 1) { /* only need to sort if two or more */
       /* Pick a random pivot. */
       pivot = array[left + RandomWord() % (right - left)];
 
@@ -751,15 +756,15 @@ void QuickSort(void *array[], Count length,
       /* Sort the smaller part now, so that we're sure to use at most
          log2 length stack levels.  Push the larger part on the stack
          for later. */
-      AVER_CRITICAL(sp < sizeof stack / sizeof stack[0]);
+      AVER_CRITICAL(sp < sizeof sortStruct->stack / sizeof sortStruct->stack[0]);
       if (leftLimit - left < right - rightBase) {
-	stack[sp].left = rightBase;
-	stack[sp].right = right;
+	sortStruct->stack[sp].left = rightBase;
+	sortStruct->stack[sp].right = right;
 	++sp;
 	right = leftLimit;
       } else {
-	stack[sp].left = left;
-	stack[sp].right = leftLimit;
+	sortStruct->stack[sp].left = left;
+	sortStruct->stack[sp].right = leftLimit;
 	++sp;
 	left = rightBase;
       }
@@ -769,9 +774,9 @@ void QuickSort(void *array[], Count length,
       break;
 
     --sp;
-    left = stack[sp].left;
-    right = stack[sp].right;
-    AVER_CRITICAL(left < right); /* we do the smaller side immediately */
+    left = sortStruct->stack[sp].left;
+    right = sortStruct->stack[sp].right;
+    AVER_CRITICAL(left < right); /* we did the smaller side earlier */
   }
 
 #ifdef QUICKSORT_DEBUG
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index 5b03ee449e0..9c5de02fb74 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -177,7 +177,8 @@ extern Word RandomWord(void);
 typedef Compare QuickSortCompare(void *left, void *right,
                                  void *closure);
 extern void QuickSort(void *array[], Count length,
-                      QuickSortCompare compare, void *closure);
+		      QuickSortCompare compare, void *closure,
+		      SortStruct *sortStruct);
 
 
 /* Version Determination
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index ea8d8bd00bd..b7e338c1319 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -677,6 +677,20 @@ typedef struct FreelistStruct {
 } FreelistStruct;
 
 
+/* SortStruct -- extra memory required by sorting
+ *
+ * See QuickSort in mpm.c.  This exists so that the caller can make
+ * the choice about where to allocate the memory, since the MPS has to
+ * operate in tight stack constraints -- see design.mps.sp.
+ */
+
+typedef struct SortStruct {
+  struct {
+    Index left, right;
+  } stack[MPS_WORD_WIDTH];
+} SortStruct;
+
+
 /* ShieldStruct -- per-arena part of the shield
  *
  * See design.mps.shield, impl.c.shield.
@@ -695,6 +709,7 @@ typedef struct ShieldStruct {
   Count unsynced;    /* number of unsynced segments */
   Count holds;       /* number of holds */
   Bool suspended;    /* mutator suspended? */
+  SortStruct sortStruct; /* workspace for queue sort */
 } ShieldStruct;
 
 
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 5245d2a9177..0a00ae8f740 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -402,7 +402,8 @@ static void shieldFlushEntries(Shield shield)
   }
 
   QuickSort((void *)shield->queue, shield->limit,
-            shieldQueueEntryCompare, UNUSED_POINTER);
+            shieldQueueEntryCompare, UNUSED_POINTER,
+	    &shield->sortStruct);
 
   mode = AccessSetEMPTY;
   for (i = 0; i < shield->limit; ++i) {

From c1c7c0cca336335f65ac6d204f054231976dc11f Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 13:54:22 +0000
Subject: [PATCH 50/69] Bracketing out unused stringequal and tidying up
 stringlength.

Copied from Perforce
 Change: 190333
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.c | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

diff --git a/mps/code/mpm.c b/mps/code/mpm.c
index 882a46b7092..a31ab2b5388 100644
--- a/mps/code/mpm.c
+++ b/mps/code/mpm.c
@@ -619,16 +619,19 @@ Res WriteF_firstformat_v(mps_lib_FILE *stream, Count depth,
 
 size_t StringLength(const char *s)
 {
-  size_t i;
+  size_t i = 0;
 
   AVER(s != NULL);
 
-  for(i = 0; s[i] != '\0'; i++)
-    NOOP;
-  return(i);
+  while (s[i] != '\0')
+    ++i;
+  
+  return i;
 }
 
 
+#if 0 /* This code is currently not in use in the MPS */
+
 /* StringEqual -- slow substitute for (strcmp == 0) */
 
 Bool StringEqual(const char *s1, const char *s2)
@@ -649,6 +652,8 @@ Bool StringEqual(const char *s1, const char *s2)
   return TRUE;
 }
 
+#endif /* not currently in use */
+
 
 
 /* C. COPYRIGHT AND LICENSE

From 0f3a469fa760790586ac19e526ea7648d67ed895 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 14:23:14 +0000
Subject: [PATCH 51/69] Responding to review by gdr
 <https://info.ravenbrook.com/mail/2016/03/21/21-05-49/0/>.

Copied from Perforce
 Change: 190336
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpmst.h  | 2 +-
 mps/code/seg.c    | 3 ++-
 mps/code/shield.c | 6 ++++++
 3 files changed, 9 insertions(+), 2 deletions(-)

diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index b7e338c1319..99c63458825 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -699,7 +699,7 @@ typedef struct SortStruct {
 #define ShieldSig      ((Sig)0x519581E1) /* SIGnature SHEILd */
 
 typedef struct ShieldStruct {
-  Sig sig;
+  Sig sig;           /* design.mps.sig */
   Bool inside;       /* design.mps.shield.def.inside */
   Seg *queue;        /* queue of unsynced segs */
   Count length;      /* number of elements in shield queue */
diff --git a/mps/code/seg.c b/mps/code/seg.c
index e7c43c31ddf..bd0abeb018b 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -224,7 +224,7 @@ static void SegFinish(Seg seg)
   AVER(seg->depth == 0);
   if (seg->queued)
     ShieldFlush(PoolArena(SegPool(seg)));
-  AVER(seg->queued == FALSE);
+  AVER(!seg->queued);
 
   limit = SegLimit(seg);
   
@@ -686,6 +686,7 @@ Bool SegCheck(Seg seg)
   CHECKL(AddrIsArenaGrain(TractBase(seg->firstTract), arena));
   CHECKL(AddrIsArenaGrain(seg->limit, arena));
   CHECKL(seg->limit > TractBase(seg->firstTract));
+  CHECKL(BoolCheck(seg->queued));
 
   /* Each tract of the segment must agree about white traces. Note
    * that even if the CHECKs are compiled away there is still a
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 0a00ae8f740..61976403a5c 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -46,6 +46,12 @@ void ShieldDestroyQueue(Shield shield, Arena arena)
 
 void ShieldFinish(Shield shield)
 {
+  /* The queue should already have been destroyed by
+     GlobalsPrepareToDestroy calling ShieldDestroyQueue. */
+  AVER(shield->length == 0);
+  AVER(shield->limit == 0);
+  AVER(shield->queue == NULL);
+
   AVER(shield->depth == 0);
   AVER(shield->unsynced == 0);
   AVER(shield->holds == 0);

From 20f558f64abc49bbdf4b13cc29b8f04b5a6ab60d Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 14:37:54 +0000
Subject: [PATCH 52/69] Improving commentary in response to nb
 <https://info.ravenbrook.com/mail/2016/03/22/17-19-03/0/>.

Copied from Perforce
 Change: 190339
 ServerID: perforce.ravenbrook.com
---
 mps/code/mpm.c    | 16 +++++++++-------
 mps/code/shield.c | 10 ++++++----
 2 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/mps/code/mpm.c b/mps/code/mpm.c
index 56b5c3973c8..1781b6959a4 100644
--- a/mps/code/mpm.c
+++ b/mps/code/mpm.c
@@ -721,8 +721,9 @@ void QuickSort(void *array[], Count length,
       /* Pick a random pivot. */
       pivot = array[left + RandomWord() % (right - left)];
 
-      /* Hoare partition: scan from lo to hi, dividing it into elements
-         less than the pivot and elements greater or equal. */
+      /* Hoare partition: scan from left to right, dividing it into
+         elements less than the pivot and elements greater or
+         equal. */
       lo = left;
       hi = right;
       for (;;) {
@@ -739,10 +740,11 @@ void QuickSort(void *array[], Count length,
         ++lo; /* step over what we just swapped */
       }
 
-      /* If we ended up at a pivot, then it is in its final position
-         and we must skip it to ensure termination.  This handles the case
-         where the pivot is at the start of the array, and one of the
-         partitions is the whole array, for example. */
+      /* After partition, if we ended up at a pivot, then it is in its
+         final position and we must skip it to ensure termination.
+         This handles the case where the pivot is at the start of the
+         array, and one of the partitions is the whole array, for
+         example. */
       if (lo == hi) {
         AVER_CRITICAL(array[hi] == pivot); /* and it's in place */
         leftLimit = lo;
@@ -776,7 +778,7 @@ void QuickSort(void *array[], Count length,
     --sp;
     left = sortStruct->stack[sp].left;
     right = sortStruct->stack[sp].right;
-    AVER_CRITICAL(left < right); /* we did the smaller side earlier */
+    AVER_CRITICAL(left < right); /* we will have done a zero-length part first */
   }
 
 #ifdef QUICKSORT_DEBUG
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 61976403a5c..6ec445e2215 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -398,7 +398,7 @@ static Compare shieldQueueEntryCompare(void *left, void *right, void *closure)
 
 static void shieldFlushEntries(Shield shield)
 {
-  Addr base = NULL, limit = NULL;
+  Addr base = NULL, limit;
   AccessSet mode;
   Index i;
 
@@ -412,10 +412,10 @@ static void shieldFlushEntries(Shield shield)
 	    &shield->sortStruct);
 
   mode = AccessSetEMPTY;
+  limit = NULL;
   for (i = 0; i < shield->limit; ++i) {
     Seg seg = shieldDequeue(shield, i);
     if (!SegIsSynced(seg)) {
-      AVER(SegSM(seg) != AccessSetEMPTY); /* can't match first iter */
       shieldSetPM(shield, seg, SegSM(seg));
       if (SegSM(seg) != mode || SegBase(seg) != limit) {
         if (mode != AccessSetEMPTY) {
@@ -651,8 +651,10 @@ static void shieldDebugCheck(Arena arena)
 /* ShieldFlush -- empty the shield queue
  *
  * .shield.flush: Flush empties the shield queue.  This needs to be
- * called before segments in the queue are destroyed, as there may be
- * references to them in the queue.
+ * called before queued segments are destroyed, to remove them from
+ * the queue.  We flush the whole queue because finding the entry is
+ * O(n) and we're very likely reclaiming and destroying loads of
+ * segments.  See also design.mps.shield.improv.resume.
  *
  * The memory for the segment may become spare, and not released back
  * to the operating system. Since we keep track of protection on

From d161c0e4eed57078be4c934847062c442d833c3a Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 15:48:58 +0000
Subject: [PATCH 53/69] Forgot shieldhold/shieldrelease in tracecondemnzones. 
 caught by hot builds of amcssth.

Copied from Perforce
 Change: 190344
 ServerID: perforce.ravenbrook.com
---
 mps/code/trace.c | 17 +++++++++++------
 1 file changed, 11 insertions(+), 6 deletions(-)

diff --git a/mps/code/trace.c b/mps/code/trace.c
index 148db0166bf..894d1715d49 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -408,6 +408,8 @@ Res TraceCondemnZones(Trace trace, ZoneSet condemnedSet)
 
   arena = trace->arena;
 
+  ShieldHold(arena); /* .whiten.hold */
+
   if(SegFirst(&seg, arena)) {
     do {
       /* Segment should be black now. */
@@ -430,6 +432,8 @@ Res TraceCondemnZones(Trace trace, ZoneSet condemnedSet)
     } while (SegNext(&seg, arena, seg));
   }
 
+  ShieldRelease(arena);
+
   EVENT3(TraceCondemnZones, trace, condemnedSet, trace->white);
 
   /* The trace's white set must be a subset of the condemned set */
@@ -438,6 +442,7 @@ Res TraceCondemnZones(Trace trace, ZoneSet condemnedSet)
   return ResOK;
 
 failBegin:
+  ShieldRelease(arena);
   AVER(TraceIsEmpty(trace)); /* See .whiten.fail. */
   return res;
 }
@@ -1483,12 +1488,12 @@ static Res traceCondemnAll(Trace trace)
   arena = trace->arena;
   AVERT(Arena, arena);
 
-  /* We suspend the mutator threads so that the PoolWhiten methods */
-  /* can calculate white sets without the mutator allocating in */
-  /* buffers under our feet. */
-  /* @@@@ This is a short-term fix for request.dylan.160098_. */
-  /* .. _request.dylan.160098: https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/dylan/160098 */
-  /* TODO: Where is the corresponding ShieldRelease? */
+  /* .whiten.hold: We suspend the mutator threads so that the
+     PoolWhiten methods can calculate white sets without the mutator
+     allocating in buffers under our feet. See request.dylan.160098
+     <https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/dylan/160098>. */
+  /* TODO: Consider how to avoid this suspend in order to implement
+     incremental condemn. */
   ShieldHold(arena);
 
   /* Condemn all segments in pools with the GC attribute. */

From 33b28efbdbd5f40266b37ac904ea25a75c62777e Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 17:31:59 +0000
Subject: [PATCH 54/69] Responding to review by nb
 <https://info.ravenbrook.com/mail/2016/03/22/17-19-03/0/>.

Copied from Perforce
 Change: 190349
 ServerID: perforce.ravenbrook.com
---
 mps/code/seg.c        |  3 ++-
 mps/code/shield.c     |  6 +++---
 mps/design/shield.txt | 25 +++++++++++++++++++++++++
 3 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/mps/code/seg.c b/mps/code/seg.c
index bd0abeb018b..d83443fad06 100644
--- a/mps/code/seg.c
+++ b/mps/code/seg.c
@@ -686,7 +686,8 @@ Bool SegCheck(Seg seg)
   CHECKL(AddrIsArenaGrain(TractBase(seg->firstTract), arena));
   CHECKL(AddrIsArenaGrain(seg->limit, arena));
   CHECKL(seg->limit > TractBase(seg->firstTract));
-  CHECKL(BoolCheck(seg->queued));
+  /* Can't BoolCheck seg->queued because compilers warn about that on
+     single-bit fields. */
 
   /* Each tract of the segment must agree about white traces. Note
    * that even if the CHECKs are compiled away there is still a
diff --git a/mps/code/shield.c b/mps/code/shield.c
index 6ec445e2215..d27c2611288 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -466,9 +466,7 @@ static void shieldQueue(Arena arena, Seg seg)
     return;
   }
 
-  /* Allocate shield queue if necessary. */
-  /* TODO: This will try to extend the queue on every attempt, even
-     if it failed last time. That might be slow. */
+  /* Allocate or extend the shield queue if necessary. */
   if (shield->next >= shield->length) {
     void *p;
     Res res;
@@ -509,6 +507,8 @@ static void shieldQueue(Arena arena, Seg seg)
   AVER_CRITICAL(shield->limit <= shield->length);
   AVER_CRITICAL(shield->next <= shield->limit);
 
+  /* If we failed to extend the shield queue array, degrade to an LRU
+     circular buffer. */
   if (shield->next >= shield->length)
     shield->next = 0;
   AVER_CRITICAL(shield->next < shield->length);
diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index a93736f8a16..13743d3496b 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -342,6 +342,31 @@ to suspend it again (no more calls to ``ShieldRaise`` or
 ``ShieldExpose`` on shielded segments).
 
 
+Expose modes
+............
+
+.improv.expose-modes: Would it be a good idea for ShieldExpose() to
+take an AccessSet? It might be good if we didn't have to raise a write
+barrier unless we want to write.  When scanning (for instance), we may
+not need to write, so when scanning a segment behind a write barrier
+we shouldn't have to call mprotect().  That's a bit speculative: how
+often do we scan a segment and not write to it.  Alternatively, and
+more speculatively, we could keep the write barrier up, handle the
+(possibly nested) trap and *then* expose the shield.  I'm just
+scraping around for ways to reduce calls to mprotect().
+
+Theoretically we can do this, but:
+
+ 1. We're mostly a moving collector so we'll almost always want to
+    write to segments we scan.  That could change if we do more
+    non-moving collection.
+
+ 2. The main cost of protection is changing it at all, not whether we
+    change just read or write.  On OS X, the main cost seems to be the
+    TLB flush, which affects wall-clock time of everything on the
+    processor!
+
+
 References
 ----------
 

From 97e64d3666d11dce008c53faad6a43540175d283 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 17:35:25 +0000
Subject: [PATCH 55/69] Design document formatting fix.

Copied from Perforce
 Change: 190350
 ServerID: perforce.ravenbrook.com
---
 mps/design/shield.txt | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index 13743d3496b..eab5410be43 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -80,8 +80,8 @@ The MPS can only gain exclusive access from "inside" the shield
 ``ArenaLeave`` so almost all of the MPS is is "inside" the shield.
 
 
-Collector access to aegments
-----------------------------
+Collector access to segments
+............................
 
 When the MPS wants to access object memory segments from inside the
 shield, it must wrap any accesses with a ``ShieldExpose`` and

From b635b8e701b7a0d52a4fbd0b458e5f1e97604884 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 17:54:43 +0000
Subject: [PATCH 56/69] Improving markup of cross-references.

Copied from Perforce
 Change: 190351
 ServerID: perforce.ravenbrook.com
---
 mps/design/shield.txt | 78 +++++++++++++++++++++----------------------
 1 file changed, 39 insertions(+), 39 deletions(-)

diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index eab5410be43..b10bf6771bd 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -49,7 +49,7 @@ Mutator access
 
 The shield provides ``ShieldRaise`` and ``ShieldLower`` to forbid or
 permit the mutator access to object memory segments.  Between these
-two, a segment is said to have the shield "raised" (.def.raised).
+two, a segment is said to have the shield "raised" (`.def.raised`_).
 
 ``void ShieldRaise(Arena arena, Seg seg, AccessSet mode)``
 
@@ -73,7 +73,7 @@ Entering the shield
 ...................
 
 The MPS can only gain exclusive access from "inside" the shield
-(.def.inside).  To enter the shield, the MPS must call
+(`.def.inside`_).  To enter the shield, the MPS must call
 ``ShieldEnter``, and to leave it, the MPS must call ``ShieldLeave``.
 
 ``ShieldEnter`` and ``ShieldLeave`` are called by ``ArenaEnter`` and
@@ -145,10 +145,10 @@ usage count reaches zero, there is no longer any reason the segment
 should be unprotected, and the shield may reinstate hardware
 protection at any time.
 
-.impl.delay: However, as a performance-improving hysteresis, the
-shield defers re-protection, maintaining a queue of segments that
-require attention before mutator threads are resumed.  While a segment
-is in the queue, it has ``seg->queued`` set to TRUE.
+However, as a performance-improving hysteresis, the shield defers
+re-protection, maintaining a queue of segments that require attention
+before mutator threads are resumed (`.impl.delay`_).  While a segment is
+in the queue, it has ``seg->queued`` set to TRUE.
 
 This hysteresis allows the MPS to proceed with garbage collection
 during a pause without actually setting hardware protection until it
@@ -157,14 +157,14 @@ systems where the protection is expensive and poorly implemented, such
 as OS X.
 
 The queue also ensures that no memory protection system calls will be
-neededIf a complete collection cycle occurs during one pause, allowing
-the MPS to operate in a non-incremental mode.
+needed if a complete collection cycle occurs during one pause,
+allowing the MPS to operate in a non-incremental mode.
 
 
 Implementation
 --------------
 
-.impl.delay: The implementation of the shield avoids suspending
+_`.impl.delay`: The implementation of the shield avoids suspending
 threads for as long as possible.  When threads are suspended, it
 maintains a queue of segments where the desired and actual protection
 do not match.  This queue is flushed on leaving the shield.
@@ -173,17 +173,17 @@ do not match.  This queue is flushed on leaving the shield.
 Definitions
 ...........
 
-.def.raised: A segment has the shield "raised" for an access mode
+_`.def.raised`: A segment has the shield "raised" for an access mode
 after a call to ``ShieldRaise`` and before a call to ``ShieldLower``
 with that mode.
 
-.def.exposed: A segment is "exposed" after a call to ``ShieldExpose``
+_`.def.exposed`: A segment is "exposed" after a call to ``ShieldExpose``
 and before a call to ``ShieldLower``.
 
-.def.synced: A seg is synced if the prot and shield modes are the
+_`.def.synced`: A seg is synced if the prot and shield modes are the
 same, and unsynced otherwise.
 
-.def.depth: The depth of a segment is defined as:
+_`.def.depth`: The depth of a segment is defined as:
 
   | depth ≔ #exposes − #covers, where
   |    #exposes = the number of calls to ``ShieldExpose`` on the seg
@@ -192,54 +192,54 @@ same, and unsynced otherwise.
 ``ShieldCover`` should not be called without a matching
 ``ShieldExpose``, so this figure should always be non-negative.
 
-.def.total.depth: The total depth is the sum of the depth over all
+_`.def.total.depth`: The total depth is the sum of the depth over all
 segments.
 
-.def.outside: Being outside the shield is being between calls to
-``ShieldLeave`` and ``ShieldEnter``, and similarly .def.inside: being
+_`.def.outside`: Being outside the shield is being between calls to
+``ShieldLeave`` and ``ShieldEnter``, and similarly _`.def.inside`: being
 inside the shield is being between calls to ``ShieldEnter`` and
 ``ShieldLeave``.  [In a multi-threaded MPS this would be per-thread.
 RB 2016-03-18]
 
-.def.suspended: Suspended is true iff the mutator is
+_`.def.suspended`: Suspended is true iff the mutator is
 suspended. [Between calls to ThreadSuspend and ThreadResume?]
 
-.def.shielded: A segment is shielded if the shield mode is
+_`.def.shielded`: A segment is shielded if the shield mode is
 non-zero. [As set by ShieldRaise.]
 
 
 Properties
 ..........
 
-.prop.outside.running: The mutator may not be suspended while outside
+_`.prop.outside.running`: The mutator may not be suspended while outside
 the shield.
 
-.prop.mutator.access: An attempt by the mutator to access shielded
+_`.prop.mutator.access`: An attempt by the mutator to access shielded
 memory be pre-empted by a call to ``ArenaAccess``.
 
-.prop.inside.access: Inside the shield the MPS must be able to access
+_`.prop.inside.access`: Inside the shield the MPS must be able to access
 all unshielded segments and all exposed segments.
 
 
 Invariants
 ..........
 
-.inv.outside.running: The mutator is not suspended while outside the
+_`.inv.outside.running`: The mutator is not suspended while outside the
 shield.
 
-.inv.unsynced.suspended: If any segment is not synced, the mutator is
+_`.inv.unsynced.suspended`: If any segment is not synced, the mutator is
 suspended.
 
-.inv.unsynced.depth: All unsynced segments have positive depth or are
+_`.inv.unsynced.depth`: All unsynced segments have positive depth or are
 in the queue.
 
-.inv.outside.depth: The total depth is zero while outside the shield.
+_`.inv.outside.depth`: The total depth is zero while outside the shield.
 
-.inv.prot.shield: The prot mode is never more than the shield mode.
+_`.inv.prot.shield`: The prot mode is never more than the shield mode.
 
-.inv.expose.depth: An exposed seg's depth is greater than zero.
+_`.inv.expose.depth`: An exposed seg's depth is greater than zero.
 
-.inv.expose.prot: An exposed seg is not protected in the mode it was
+_`.inv.expose.prot`: An exposed seg is not protected in the mode it was
 exposed with.
 
 
@@ -248,22 +248,22 @@ Proof Hints
 
 Hints at proofs of properties from invariants.
 
-.proof.outside: .inv.outside.running directly ensures .prop.outside
+_`.proof.outside`: .inv.outside.running directly ensures .prop.outside
 running.
 
-.proof.sync: As the depth of a segment cannot be negative
+_`.proof.sync`: As the depth of a segment cannot be negative
 
   | total depth = 0
   |   ⇒ for all segments, depth = 0
   |   ⇒ all segs are synced (by .inv.unsynced.depth)
 
-.proof.access: If the mutator is running then all segs must be synced
+_`.proof.access`: If the mutator is running then all segs must be synced
 (.inv.unsynced.suspend).  Which means that the hardware protection
 (.prot mode) must reflect the software protection (shield mode).
 Hence all shielded memory will be hardware protected while the mutator
 is running.  This ensures .prop.mutator.access.
 
-.proof.inside: .inv.prot.shield and .inv.expose.prot ensure
+_`.proof.inside`: .inv.prot.shield and .inv.expose.prot ensure
 .prop.inside.access.
 
 
@@ -281,7 +281,7 @@ Improvement Ideas
 Mass exposure
 .............
 
-.improv.mass-expose: If protection calls have a high overhead it might
+_`.improv.mass-expose`: If protection calls have a high overhead it might
 be good to pre-emptively unprotect large ranges of memory when we
 expose one segment.  With the current design this would mean
 discovering adjacent shielded segments and adding them to the queue.
@@ -292,7 +292,7 @@ exposed segments during a pause.
 Segment independence
 ....................
 
-.improve.noseg: The shield is implemented in terms of segments, using
+_`.improve.noseg`: The shield is implemented in terms of segments, using
 fields in the segment structure to represent its state. This forces us
 to (for example) flush the shield queue when deleting a segment. The
 shield could keep track of protection and shielding independently,
@@ -303,7 +303,7 @@ use of system calls (see .improve.mass-expose).
 Concurrent collection
 .....................
 
-.improv.concurrent: The MPS currently does not collect concurrently,
+_`.improv.concurrent`: The MPS currently does not collect concurrently,
 however the only thing that makes it not-concurrent is a critical
 point in the Shield abstraction where the MPS seeks to gain privileged
 access to memory (usually in order to scan it for GC). The critical
@@ -332,7 +332,7 @@ MPS design. It's kind of waiting to happen.
 Early Resume
 ............
 
-.improv.resume: There is a tradeoff between delaying flushing the
+_`.improv.resume`: There is a tradeoff between delaying flushing the
 shield queue (preventing unnecessary protection and allowing us to
 coalesce) and resuming mutator threads.  We could resume threads
 earlier under some circumstances, such as before reclaim (which does
@@ -345,7 +345,7 @@ to suspend it again (no more calls to ``ShieldRaise`` or
 Expose modes
 ............
 
-.improv.expose-modes: Would it be a good idea for ShieldExpose() to
+_`.improv.expose-modes`: Would it be a good idea for ShieldExpose() to
 take an AccessSet? It might be good if we didn't have to raise a write
 barrier unless we want to write.  When scanning (for instance), we may
 not need to write, so when scanning a segment behind a write barrier
@@ -406,8 +406,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without

From f3b84793229b97197823a894693e426b67b599ee Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 17:55:22 +0000
Subject: [PATCH 57/69] Improving commentary: the mutator is suspended, not the
 arena.

Copied from Perforce
 Change: 190352
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index d27c2611288..71ee4ec0950 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -442,7 +442,7 @@ static void shieldFlushEntries(Shield shield)
 /* shieldQueue -- consider adding a segment to the queue
  *
  * If the segment is out of sync, either sync it, or ensure it is
- * queued and the arena is suspended.
+ * queued and the mutator is suspended.
  */
 
 static void shieldQueue(Arena arena, Seg seg)

From eb1d39c425514b18a4e5b0e4559eb75cc6342bdc Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 23 Mar 2016 19:03:00 +0000
Subject: [PATCH 58/69] Improving shieldflushentries to allow for delayed
 protection changes on shieldlower.

Copied from Perforce
 Change: 190363
 ServerID: perforce.ravenbrook.com
---
 mps/code/shield.c | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/mps/code/shield.c b/mps/code/shield.c
index 71ee4ec0950..43eb3e284c5 100644
--- a/mps/code/shield.c
+++ b/mps/code/shield.c
@@ -226,8 +226,8 @@ static void shieldSync(Shield shield, Seg seg)
   SHIELD_AVERT_CRITICAL(Seg, seg);
 
   if (!SegIsSynced(seg)) {
-    ProtSet(SegBase(seg), SegLimit(seg), SegSM(seg));
     shieldSetPM(shield, seg, SegSM(seg));
+    ProtSet(SegBase(seg), SegLimit(seg), SegPM(seg));
   }
 }
 
@@ -418,8 +418,7 @@ static void shieldFlushEntries(Shield shield)
     if (!SegIsSynced(seg)) {
       shieldSetPM(shield, seg, SegSM(seg));
       if (SegSM(seg) != mode || SegBase(seg) != limit) {
-        if (mode != AccessSetEMPTY) {
-          AVER(base != NULL);
+        if (base != NULL) {
           AVER(base < limit);
           ProtSet(base, limit, mode);
         }
@@ -429,9 +428,8 @@ static void shieldFlushEntries(Shield shield)
       limit = SegLimit(seg);
     }
   }
-  if (mode != AccessSetEMPTY) {
-    AVER(base != NULL);
-    AVER(limit != NULL);
+  if (base != NULL) {
+    AVER(base < limit);
     ProtSet(base, limit, mode);
   }
 
@@ -580,6 +578,7 @@ void (ShieldLower)(Arena arena, Seg seg, AccessSet mode)
   /* TODO: Do we need to promptly call shieldProtLower here?  It
      loses the opportunity to coalesce the protection call. It would
      violate design.mps.shield.prop.inside.access. */
+  /* shieldQueue(arena, seg); */
   shieldProtLower(shield, seg, mode);
 
   /* Check queue and segment consistency. */

From 06d330a2cb2b472b98865900dbf5b5d1f0a6e79f Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 03:25:28 +0000
Subject: [PATCH 59/69] Adding release note about write barrier deferral.

Copied from Perforce
 Change: 190358
 ServerID: perforce.ravenbrook.com
---
 mps/manual/source/release.rst | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/mps/manual/source/release.rst b/mps/manual/source/release.rst
index 1a70fd0b0b2..6816fc16087 100644
--- a/mps/manual/source/release.rst
+++ b/mps/manual/source/release.rst
@@ -141,6 +141,14 @@ Other changes
 
    .. _job003938: https://www.ravenbrook.com/project/mps/issue/job003938/
 
+#. The MPS is less aggressive in its use of hardware memory protection
+   to maintain :term:`write barrier` to speed up future collections.
+   This is particularly important for OS X, where memory protection is
+   poorly implemented.  See job003371_ and job003975_.
+
+   .. _job003371: http://www.ravenbrook.com/project/mps/issue/job003371/
+   .. _job003975: http://www.ravenbrook.com/project/mps/issue/job003975/
+
 
 .. _release-notes-1.114:
 

From fb816556409120eac517927adc34227e9562d8ff Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 03:35:58 +0000
Subject: [PATCH 60/69] Writing release note about shield coalescing.

Copied from Perforce
 Change: 190364
 ServerID: perforce.ravenbrook.com
---
 mps/manual/source/release.rst | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/mps/manual/source/release.rst b/mps/manual/source/release.rst
index 1a70fd0b0b2..e976a4a4ea2 100644
--- a/mps/manual/source/release.rst
+++ b/mps/manual/source/release.rst
@@ -141,6 +141,14 @@ Other changes
 
    .. _job003938: https://www.ravenbrook.com/project/mps/issue/job003938/
 
+#. The MPS coalesces memory protection, reducing the number of system
+   calls. This drastically improves real run time on operating systems
+   where memory protection is poorly implemented, such as OS X, but
+   also has a significant effect on Linux. See job003371_ and
+   job003975_.
+
+   .. _job003371: http://www.ravenbrook.com/project/mps/issue/job003371/
+   .. _job003975: http://www.ravenbrook.com/project/mps/issue/job003975/
 
 .. _release-notes-1.114:
 

From 4f3a29c419bb8c8c48f6a6b1973a83dafcac5679 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 10:29:54 +0000
Subject: [PATCH 61/69] Miscellaneous corrections to shield design.

Promoting shield design from "old" to "current" in the manual.

Copied from Perforce
 Change: 190369
 ServerID: perforce.ravenbrook.com
---
 mps/design/shield.txt              | 32 +++++++++++++-----------------
 mps/manual/source/design/index.rst |  3 ++-
 mps/manual/source/design/old.rst   |  1 -
 3 files changed, 16 insertions(+), 20 deletions(-)

diff --git a/mps/design/shield.txt b/mps/design/shield.txt
index b10bf6771bd..9b56c96a466 100644
--- a/mps/design/shield.txt
+++ b/mps/design/shield.txt
@@ -108,7 +108,7 @@ need never expose them to gain access.
 Collector access to the unprotectable
 .....................................
 
-Then the MPS wants to access an unprotectable object from inside the
+When the MPS wants to access an unprotectable object from inside the
 shield, it must wrap any accesses with a ``ShieldHold`` and
 ``ShieldRelease`` pair.  This allows access to objects which cannot be
 shielded by ``ShieldRaise``, such as:
@@ -134,7 +134,7 @@ On common operating systems, the only way to allow the MPS access is
 to allow access from the whole process, including the mutator. So
 ``ShieldExpose`` will suspend all mutator threads to prevent any mutator
 access, and so will ``ShieldRaise`` on an unexposed segment. The
-shield handles suspending and resuming threads, and the the rest of
+shield handles suspending and resuming threads, and so the rest of
 the MPS does not need to worry about it.
 
 The MPS can make multiple sequential, overlapping, or nested calls to
@@ -148,7 +148,7 @@ protection at any time.
 However, as a performance-improving hysteresis, the shield defers
 re-protection, maintaining a queue of segments that require attention
 before mutator threads are resumed (`.impl.delay`_).  While a segment is
-in the queue, it has ``seg->queued`` set to TRUE.
+in the queue, it has ``seg->queued`` set true.
 
 This hysteresis allows the MPS to proceed with garbage collection
 during a pause without actually setting hardware protection until it
@@ -157,8 +157,8 @@ systems where the protection is expensive and poorly implemented, such
 as OS X.
 
 The queue also ensures that no memory protection system calls will be
-needed if a complete collection cycle occurs during one pause,
-allowing the MPS to operate in a non-incremental mode.
+needed for incremental garbage collection if a complete collection
+cycle occurs during one pause.
 
 
 Implementation
@@ -201,9 +201,6 @@ inside the shield is being between calls to ``ShieldEnter`` and
 ``ShieldLeave``.  [In a multi-threaded MPS this would be per-thread.
 RB 2016-03-18]
 
-_`.def.suspended`: Suspended is true iff the mutator is
-suspended. [Between calls to ThreadSuspend and ThreadResume?]
-
 _`.def.shielded`: A segment is shielded if the shield mode is
 non-zero. [As set by ShieldRaise.]
 
@@ -248,8 +245,8 @@ Proof Hints
 
 Hints at proofs of properties from invariants.
 
-_`.proof.outside`: .inv.outside.running directly ensures .prop.outside
-running.
+_`.proof.outside`: `.inv.outside.running`_ directly ensures
+`.prop.outside.running`_.
 
 _`.proof.sync`: As the depth of a segment cannot be negative
 
@@ -257,14 +254,13 @@ _`.proof.sync`: As the depth of a segment cannot be negative
   |   ⇒ for all segments, depth = 0
   |   ⇒ all segs are synced (by .inv.unsynced.depth)
 
-_`.proof.access`: If the mutator is running then all segs must be synced
-(.inv.unsynced.suspend).  Which means that the hardware protection
-(.prot mode) must reflect the software protection (shield mode).
-Hence all shielded memory will be hardware protected while the mutator
-is running.  This ensures .prop.mutator.access.
-
-_`.proof.inside`: .inv.prot.shield and .inv.expose.prot ensure
-.prop.inside.access.
+_`.proof.access`: If the mutator is running then all segs must be
+synced (`.inv.unsynced.suspend`_).  Which means that the hardware
+protection (protection mode) must reflect the software protection
+(shield mode).  Hence all shielded memory will be hardware protected
+while the mutator is running.  This ensures `.prop.mutator.access`_.
+_`.proof.inside`: `.inv.prot.shield`_ and `.inv.expose.prot`_ ensure
+`.prop.inside.access`_.
 
 
 Initial ideas
diff --git a/mps/manual/source/design/index.rst b/mps/manual/source/design/index.rst
index 1cea6c4861b..1c9d27f94b7 100644
--- a/mps/manual/source/design/index.rst
+++ b/mps/manual/source/design/index.rst
@@ -29,8 +29,9 @@ Design
     prot
     range
     ring
-    sp
+    shield
     sig
+    sp
     splay
     ss
     testthr
diff --git a/mps/manual/source/design/old.rst b/mps/manual/source/design/old.rst
index 69c872c773c..28b115e2335 100644
--- a/mps/manual/source/design/old.rst
+++ b/mps/manual/source/design/old.rst
@@ -48,7 +48,6 @@ Old design
     root
     scan
     seg
-    shield
     sso1al
     strategy
     telemetry

From 428e8bae9282de5244965f1779e251c9e23a924e Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 11:04:58 +0000
Subject: [PATCH 62/69] Fixing build errors on windows (w3i6mv).

tagtest was missing from makefiles.
Implicit conversion warning from Clock to double.

Copied from Perforce
 Change: 190372
 ServerID: perforce.ravenbrook.com
---
 mps/code/commpost.nmk | 3 +++
 mps/code/commpre.nmk  | 1 +
 mps/code/global.c     | 2 +-
 3 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/mps/code/commpost.nmk b/mps/code/commpost.nmk
index 201094905bd..35b26ee19f3 100644
--- a/mps/code/commpost.nmk
+++ b/mps/code/commpost.nmk
@@ -291,6 +291,9 @@ $(PFM)\$(VARIETY)\segsmss.exe: $(PFM)\$(VARIETY)\segsmss.obj \
 $(PFM)\$(VARIETY)\steptest.exe: $(PFM)\$(VARIETY)\steptest.obj \
 	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
 
+$(PFM)\$(VARIETY)\tagtest.exe: $(PFM)\$(VARIETY)\tagtest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
 $(PFM)\$(VARIETY)\teletest.exe: $(PFM)\$(VARIETY)\teletest.obj \
 	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
 
diff --git a/mps/code/commpre.nmk b/mps/code/commpre.nmk
index d1aa7e49d6e..c428e909fa9 100644
--- a/mps/code/commpre.nmk
+++ b/mps/code/commpre.nmk
@@ -95,6 +95,7 @@ TEST_TARGETS=\
     sacss.exe \
     segsmss.exe \
     steptest.exe \
+    tagtest.exe \
     teletest.exe \
     walkt0.exe \
     zcoll.exe \
diff --git a/mps/code/global.c b/mps/code/global.c
index 120161bbf5c..08497c7cc46 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -776,7 +776,7 @@ Bool ArenaStep(Globals globals, double interval, double multiplier)
       trace = ArenaTrace(arena, (TraceId)0);
     } else {
       /* No traces are running: consider collecting the world. */
-      if (PolicyShouldCollectWorld(arena, availableEnd - now, now,
+      if (PolicyShouldCollectWorld(arena, (double)(availableEnd - now), now,
                                    clocks_per_sec))
       {
         Res res;

From 6090670a8d417191cc13c289b9c306e830491708 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 12:42:27 +0000
Subject: [PATCH 63/69] Running autoreconf to get freebsd with clang into the
 configure script.

Copied from Perforce
 Change: 190384
 ServerID: perforce.ravenbrook.com
---
 mps/configure | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 51 insertions(+)

diff --git a/mps/configure b/mps/configure
index 2aa767cd2d5..0bdf69b11d3 100755
--- a/mps/configure
+++ b/mps/configure
@@ -3513,6 +3513,16 @@ $as_echo "FreeBSD x86" >&6; }
       CPP="$CC -I/usr/local/include -E"
       PFMCFLAGS="$CFLAGS_GC"
     ;;
+  amd64-*-freebsd*/yes | x86_64-*-freebsd*/yes)
+      { $as_echo "$as_me:${as_lineno-$LINENO}: result: FreeBSD x86_64" >&5
+$as_echo "FreeBSD x86_64" >&6; }
+      MPS_OS_NAME=fr
+      MPS_ARCH_NAME=i6
+      MPS_BUILD_NAME=ll
+      # Need /usr/local/include in order to find sqlite3.h
+      CFLAGS="-I/usr/local/include"
+      CPP="$CC -I/usr/local/include -E"
+      PFMCFLAGS="$CFLAGS_GC"
   amd64-*-freebsd*/no | x86_64-*-freebsd*/no)
       { $as_echo "$as_me:${as_lineno-$LINENO}: result: FreeBSD x86_64" >&5
 $as_echo "FreeBSD x86_64" >&6; }
@@ -4789,3 +4799,44 @@ fi
 
 
 echo 1>&2 "CONFIGURE/MAKE IS NOT THE BEST WAY TO BUILD THE MPS -- see <manual/build.txt>"
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2012-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+# All rights reserved.  This is an open source license.  Contact
+# Ravenbrook for commercial licensing options.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+#
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# 3. Redistributions in any form must be accompanied by information on how
+# to obtain complete source code for this software and any accompanying
+# software that uses this software.  The source code must either be
+# included in the distribution or be available for no more than the cost
+# of distribution plus a nominal fee, and must be freely redistributable
+# under reasonable conditions.  For an executable file, complete source
+# code means the source code for all modules it contains. It does not
+# include source code for modules or files that typically accompany the
+# major components of the operating system on which the executable file
+# runs.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+# PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
+# COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+# ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

From 1a03f7520fb574a2b0cb35062a4faaca80d5ba68 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 12:44:53 +0000
Subject: [PATCH 64/69] Fixing syntax error in detection of freebsd with clang.

Copied from Perforce
 Change: 190385
 ServerID: perforce.ravenbrook.com
---
 mps/configure    | 1 +
 mps/configure.ac | 1 +
 2 files changed, 2 insertions(+)

diff --git a/mps/configure b/mps/configure
index 0bdf69b11d3..8d938b2d09d 100755
--- a/mps/configure
+++ b/mps/configure
@@ -3523,6 +3523,7 @@ $as_echo "FreeBSD x86_64" >&6; }
       CFLAGS="-I/usr/local/include"
       CPP="$CC -I/usr/local/include -E"
       PFMCFLAGS="$CFLAGS_GC"
+    ;;
   amd64-*-freebsd*/no | x86_64-*-freebsd*/no)
       { $as_echo "$as_me:${as_lineno-$LINENO}: result: FreeBSD x86_64" >&5
 $as_echo "FreeBSD x86_64" >&6; }
diff --git a/mps/configure.ac b/mps/configure.ac
index c7928ec14bb..436aad238c6 100644
--- a/mps/configure.ac
+++ b/mps/configure.ac
@@ -107,6 +107,7 @@ case $host/$CLANG in
       CFLAGS="-I/usr/local/include"
       CPP="$CC -I/usr/local/include -E"
       PFMCFLAGS="$CFLAGS_GC"
+    ;;
   amd64-*-freebsd*/no | x86_64-*-freebsd*/no)
       AC_MSG_RESULT([FreeBSD x86_64])
       MPS_OS_NAME=fr

From cae88818754b7f7350856612cd11b70f4c147964 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 17:49:06 +0000
Subject: [PATCH 65/69] Mentioning freebsd with clang/llvm support in the
 readme.txt.

Copied from Perforce
 Change: 190389
 ServerID: perforce.ravenbrook.com
---
 mps/readme.txt | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/mps/readme.txt b/mps/readme.txt
index 2959f6eb7b4..08f0fe40b8a 100644
--- a/mps/readme.txt
+++ b/mps/readme.txt
@@ -77,7 +77,7 @@ The MPS is currently supported for deployment on:
 - Linux 2.4 or later, on IA-32 using GCC and on x86-64 using GCC or
   Clang/LLVM;
 
-- FreeBSD 7 or later, on IA-32 and x86-64, using GCC;
+- FreeBSD 7 or later, on IA-32 and x86-64, using GCC or Clang/LLVM;
 
 - OS X 10.4 or later, on IA-32 and x86-64, using Clang/LLVM.
 
@@ -132,6 +132,7 @@ Document History
                    brought to you in glorious reStructuredText.
 2014-01-13  GDR_   Updated supported platforms.
 2014-07-04  GDR_   Link to hotfix for WOW64 bug.
+2016-03-24  RB_    Adding support for FreeBSD with Clang/LLVM.
 ==========  =====  ======================================================
 
 .. _GDR: mailto:gdr@ravenbrook.com
@@ -143,7 +144,7 @@ Document History
 Copyright and Licence
 ---------------------
 
-Copyright (C) 2001-2014 Ravenbrook Limited. All rights reserved. 
+Copyright (C) 2001-2016 Ravenbrook Limited. All rights reserved. 
 <http://www.ravenbrook.com/>. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 

From 36beebd4400a4d059fdfee086f136299d9c41cfc Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Thu, 24 Mar 2016 21:59:39 +0000
Subject: [PATCH 66/69] Correcting return type of zonesetofrange to a zoneset.

Copied from Perforce
 Change: 190395
 ServerID: perforce.ravenbrook.com
---
 mps/code/ref.c | 10 +++-------
 1 file changed, 3 insertions(+), 7 deletions(-)

diff --git a/mps/code/ref.c b/mps/code/ref.c
index 3f330315556..c9b2de07aa6 100644
--- a/mps/code/ref.c
+++ b/mps/code/ref.c
@@ -1,7 +1,7 @@
 /* ref.c: REFERENCES
  *
  * $Id$
- * Copyright (c) 2001 Ravenbrook Limited.  See end of file for license.
+ * Copyright (c) 2001-2016 Ravenbrook Limited.  See end of file for license.
  *
  * .purpose: Implement operations on Ref, RefSet, ZoneSet, and Rank.
  *
@@ -35,7 +35,7 @@ Bool RankSetCheck(RankSet rankSet)
 
 /* ZoneSetOfRange -- calculate the zone set of a range of addresses */
 
-RefSet ZoneSetOfRange(Arena arena, Addr base, Addr limit)
+ZoneSet ZoneSetOfRange(Arena arena, Addr base, Addr limit)
 {
   Word zbase, zlimit;
 
@@ -292,13 +292,9 @@ ZoneSet ZoneSetBlacklist(Arena arena)
 }
 
 
-
-
-
-
 /* C. COPYRIGHT AND LICENSE
  *
- * Copyright (C) 2001-2002 Ravenbrook Limited <http://www.ravenbrook.com/>.
+ * Copyright (C) 2001-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
  * All rights reserved.  This is an open source license.  Contact
  * Ravenbrook for commercial licensing options.
  * 

From 08637d7d97d472df4d4f994371851e9eeb8db620 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 27 Mar 2016 11:14:27 +0100
Subject: [PATCH 67/69] Fixing the position of the ravenbrook url in the
 licences in design documents.

Copied from Perforce
 Change: 190434
 ServerID: perforce.ravenbrook.com
---
 mps/design/abq.txt               |  4 ++--
 mps/design/alloc-frame.txt       |  4 ++--
 mps/design/an.txt                |  4 ++--
 mps/design/arena.txt             |  4 ++--
 mps/design/arenavm.txt           |  4 ++--
 mps/design/bt.txt                |  4 ++--
 mps/design/buffer.txt            |  4 ++--
 mps/design/check.txt             |  4 ++--
 mps/design/class-interface.txt   |  4 ++--
 mps/design/clock.txt             |  4 ++--
 mps/design/collection.txt        |  4 ++--
 mps/design/config.txt            |  4 ++--
 mps/design/diag.txt              |  4 ++--
 mps/design/exec-env.txt          |  4 ++--
 mps/design/finalize.txt          |  4 ++--
 mps/design/fix.txt               |  4 ++--
 mps/design/freelist.txt          |  4 ++--
 mps/design/guide.hex.trans.txt   |  4 ++--
 mps/design/guide.review.txt      |  4 ++--
 mps/design/index.txt             |  4 ++--
 mps/design/interface-c.txt       |  4 ++--
 mps/design/io.txt                |  4 ++--
 mps/design/keyword-arguments.txt |  4 ++--
 mps/design/lib.txt               |  4 ++--
 mps/design/lock.txt              |  4 ++--
 mps/design/locus.txt             |  4 ++--
 mps/design/message-gc.txt        |  4 ++--
 mps/design/message.txt           |  4 ++--
 mps/design/nailboard.txt         |  4 ++--
 mps/design/object-debug.txt      |  4 ++--
 mps/design/pool.txt              |  4 ++--
 mps/design/poolamc.txt           |  4 ++--
 mps/design/poolams.txt           |  4 ++--
 mps/design/poolawl.txt           |  4 ++--
 mps/design/poollo.txt            |  4 ++--
 mps/design/poolmfs.txt           |  4 ++--
 mps/design/poolmrg.txt           |  4 ++--
 mps/design/poolmv.txt            |  4 ++--
 mps/design/poolmvff.txt          | 11 ++++++-----
 mps/design/prmc.txt              |  4 ++--
 mps/design/prot.txt              |  4 ++--
 mps/design/protli.txt            |  4 ++--
 mps/design/protocol.txt          |  4 ++--
 mps/design/protsu.txt            |  4 ++--
 mps/design/pthreadext.txt        |  4 ++--
 mps/design/range.txt             |  4 ++--
 mps/design/root.txt              |  4 ++--
 mps/design/sig.txt               |  4 ++--
 mps/design/sp.txt                |  4 ++--
 mps/design/splay.txt             |  4 ++--
 mps/design/ss.txt                |  4 ++--
 mps/design/sso1al.txt            |  4 ++--
 mps/design/strategy.txt          |  4 ++--
 mps/design/telemetry.txt         |  4 ++--
 mps/design/tests.txt             |  4 ++--
 mps/design/testthr.txt           |  4 ++--
 mps/design/thread-manager.txt    |  4 ++--
 mps/design/thread-safety.txt     |  4 ++--
 mps/design/trace.txt             |  4 ++--
 mps/design/type.txt              |  4 ++--
 mps/design/version-library.txt   |  4 ++--
 mps/design/version.txt           |  4 ++--
 mps/design/vm.txt                |  4 ++--
 mps/design/vmo1.txt              |  4 ++--
 mps/design/vmso.txt              |  4 ++--
 mps/design/writef.txt            |  4 ++--
 66 files changed, 136 insertions(+), 135 deletions(-)

diff --git a/mps/design/abq.txt b/mps/design/abq.txt
index cc0cfe0159f..75aaec3d1a2 100644
--- a/mps/design/abq.txt
+++ b/mps/design/abq.txt
@@ -120,8 +120,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/alloc-frame.txt b/mps/design/alloc-frame.txt
index b199c2c567f..4dac0fe9fb1 100644
--- a/mps/design/alloc-frame.txt
+++ b/mps/design/alloc-frame.txt
@@ -473,8 +473,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/an.txt b/mps/design/an.txt
index 7d6cc117407..78ecccfeafb 100644
--- a/mps/design/an.txt
+++ b/mps/design/an.txt
@@ -176,8 +176,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/arena.txt b/mps/design/arena.txt
index 1d7f412dd86..7d6fe4c0eb7 100644
--- a/mps/design/arena.txt
+++ b/mps/design/arena.txt
@@ -616,8 +616,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2001-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/arenavm.txt b/mps/design/arenavm.txt
index d746f18d883..c43a35bb3d0 100644
--- a/mps/design/arenavm.txt
+++ b/mps/design/arenavm.txt
@@ -235,8 +235,8 @@ management of page table mapping.
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/bt.txt b/mps/design/bt.txt
index bc069efd2a9..4d6a40b8460 100644
--- a/mps/design/bt.txt
+++ b/mps/design/bt.txt
@@ -751,8 +751,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/buffer.txt b/mps/design/buffer.txt
index 04b8779e2ca..a15a63c76f0 100644
--- a/mps/design/buffer.txt
+++ b/mps/design/buffer.txt
@@ -736,8 +736,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/check.txt b/mps/design/check.txt
index 138c2a7fc1d..2cf5bf091c6 100644
--- a/mps/design/check.txt
+++ b/mps/design/check.txt
@@ -138,8 +138,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/class-interface.txt b/mps/design/class-interface.txt
index 65cc8accb2a..00925e51019 100644
--- a/mps/design/class-interface.txt
+++ b/mps/design/class-interface.txt
@@ -264,8 +264,8 @@ Document history
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/clock.txt b/mps/design/clock.txt
index d9b73d43081..3213d6ccff5 100644
--- a/mps/design/clock.txt
+++ b/mps/design/clock.txt
@@ -93,8 +93,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/collection.txt b/mps/design/collection.txt
index ebf0c05df9f..9adea762c5e 100644
--- a/mps/design/collection.txt
+++ b/mps/design/collection.txt
@@ -419,8 +419,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/config.txt b/mps/design/config.txt
index 9d49a5889ce..544b9a61ed1 100644
--- a/mps/design/config.txt
+++ b/mps/design/config.txt
@@ -610,8 +610,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/diag.txt b/mps/design/diag.txt
index f8e86e2bdda..15384db203b 100644
--- a/mps/design/diag.txt
+++ b/mps/design/diag.txt
@@ -193,8 +193,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/exec-env.txt b/mps/design/exec-env.txt
index 29576212b4a..71d7287f057 100644
--- a/mps/design/exec-env.txt
+++ b/mps/design/exec-env.txt
@@ -149,8 +149,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 1996-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 1996-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/finalize.txt b/mps/design/finalize.txt
index e3668716df7..b8e47021a0a 100644
--- a/mps/design/finalize.txt
+++ b/mps/design/finalize.txt
@@ -139,8 +139,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/fix.txt b/mps/design/fix.txt
index dce6b561c84..7bd8b3a9b89 100644
--- a/mps/design/fix.txt
+++ b/mps/design/fix.txt
@@ -73,8 +73,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/freelist.txt b/mps/design/freelist.txt
index c89181505c1..c86ae9a9f14 100644
--- a/mps/design/freelist.txt
+++ b/mps/design/freelist.txt
@@ -172,8 +172,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/guide.hex.trans.txt b/mps/design/guide.hex.trans.txt
index 8120f6e53e5..bf20d099096 100644
--- a/mps/design/guide.hex.trans.txt
+++ b/mps/design/guide.hex.trans.txt
@@ -144,8 +144,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/guide.review.txt b/mps/design/guide.review.txt
index 4bed3049842..52d8f4635ea 100644
--- a/mps/design/guide.review.txt
+++ b/mps/design/guide.review.txt
@@ -56,8 +56,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2015-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2015-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/index.txt b/mps/design/index.txt
index 7c889f1ee30..e486020574d 100644
--- a/mps/design/index.txt
+++ b/mps/design/index.txt
@@ -240,8 +240,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2002-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2002-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/interface-c.txt b/mps/design/interface-c.txt
index 1e5424105b7..912b4aa9bdf 100644
--- a/mps/design/interface-c.txt
+++ b/mps/design/interface-c.txt
@@ -405,8 +405,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/io.txt b/mps/design/io.txt
index 27ab9d7802a..0a89d5e6d41 100644
--- a/mps/design/io.txt
+++ b/mps/design/io.txt
@@ -431,8 +431,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2015 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/keyword-arguments.txt b/mps/design/keyword-arguments.txt
index af6db232a5a..5a7f1d1f1a5 100644
--- a/mps/design/keyword-arguments.txt
+++ b/mps/design/keyword-arguments.txt
@@ -163,8 +163,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/lib.txt b/mps/design/lib.txt
index 1dd7efe6964..1da7f673c49 100644
--- a/mps/design/lib.txt
+++ b/mps/design/lib.txt
@@ -95,8 +95,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2015 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/lock.txt b/mps/design/lock.txt
index 069474ae428..ed1bbcd14a7 100644
--- a/mps/design/lock.txt
+++ b/mps/design/lock.txt
@@ -287,8 +287,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/locus.txt b/mps/design/locus.txt
index 4777857c9d7..ebee711f481 100644
--- a/mps/design/locus.txt
+++ b/mps/design/locus.txt
@@ -700,8 +700,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/message-gc.txt b/mps/design/message-gc.txt
index f69a3d2c3f0..94de3049552 100644
--- a/mps/design/message-gc.txt
+++ b/mps/design/message-gc.txt
@@ -317,8 +317,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/message.txt b/mps/design/message.txt
index 807f9cc6cdd..1c5d4210914 100644
--- a/mps/design/message.txt
+++ b/mps/design/message.txt
@@ -407,8 +407,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/nailboard.txt b/mps/design/nailboard.txt
index 2f88b5b57b7..cce46ac34d0 100644
--- a/mps/design/nailboard.txt
+++ b/mps/design/nailboard.txt
@@ -214,8 +214,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/object-debug.txt b/mps/design/object-debug.txt
index 627f8352c3a..a803b16eb1d 100644
--- a/mps/design/object-debug.txt
+++ b/mps/design/object-debug.txt
@@ -427,8 +427,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/pool.txt b/mps/design/pool.txt
index 2ad6d6e64d7..e54f55b60b0 100644
--- a/mps/design/pool.txt
+++ b/mps/design/pool.txt
@@ -78,8 +78,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poolamc.txt b/mps/design/poolamc.txt
index f00bc4adbae..cd1612e982d 100644
--- a/mps/design/poolamc.txt
+++ b/mps/design/poolamc.txt
@@ -813,8 +813,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poolams.txt b/mps/design/poolams.txt
index ef59e46724a..30a4efc10e7 100644
--- a/mps/design/poolams.txt
+++ b/mps/design/poolams.txt
@@ -497,8 +497,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poolawl.txt b/mps/design/poolawl.txt
index 609d236320e..88d038b80b0 100644
--- a/mps/design/poolawl.txt
+++ b/mps/design/poolawl.txt
@@ -565,8 +565,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poollo.txt b/mps/design/poollo.txt
index ebb402c316b..aae70799452 100644
--- a/mps/design/poollo.txt
+++ b/mps/design/poollo.txt
@@ -265,8 +265,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poolmfs.txt b/mps/design/poolmfs.txt
index 31fe8c24cd9..4ed24263308 100644
--- a/mps/design/poolmfs.txt
+++ b/mps/design/poolmfs.txt
@@ -44,8 +44,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poolmrg.txt b/mps/design/poolmrg.txt
index 148e016fae7..9c8de7e092e 100644
--- a/mps/design/poolmrg.txt
+++ b/mps/design/poolmrg.txt
@@ -685,8 +685,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poolmv.txt b/mps/design/poolmv.txt
index 1b25c441a27..ca51cc59c6c 100644
--- a/mps/design/poolmv.txt
+++ b/mps/design/poolmv.txt
@@ -47,8 +47,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/poolmvff.txt b/mps/design/poolmvff.txt
index d29efc6ba89..6eb2004ea01 100644
--- a/mps/design/poolmvff.txt
+++ b/mps/design/poolmvff.txt
@@ -22,9 +22,10 @@ pool class. This pool implements a first (or last) fit policy for
 variable-sized manually-managed objects, with control over first/last,
 segment preference high/low, and slot fit low/high.
 
-The pool was created in a response to a belief that the ScriptWorks
-EPDL/EPDR's first fit policy is beneficial for some classes of client
-behaviour, but the performance of a linear free list was unacceptable.
+_`.background`: The pool was created in a response to a belief that
+the ScriptWorks EPDL/EPDR's first fit policy is beneficial for some
+classes of client behaviour, but the performance of a linear free list
+was unacceptable.
 
 
 Overview
@@ -115,8 +116,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/prmc.txt b/mps/design/prmc.txt
index c7aaad52d57..e633729798f 100644
--- a/mps/design/prmc.txt
+++ b/mps/design/prmc.txt
@@ -271,8 +271,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/prot.txt b/mps/design/prot.txt
index fb06b78b328..0cdd8d38fcd 100644
--- a/mps/design/prot.txt
+++ b/mps/design/prot.txt
@@ -165,8 +165,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/protli.txt b/mps/design/protli.txt
index 8d4a2f7b395..d07ee96065e 100644
--- a/mps/design/protli.txt
+++ b/mps/design/protli.txt
@@ -217,8 +217,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/protocol.txt b/mps/design/protocol.txt
index 4dca17bcf97..38f29062913 100644
--- a/mps/design/protocol.txt
+++ b/mps/design/protocol.txt
@@ -540,8 +540,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/protsu.txt b/mps/design/protsu.txt
index e31edf3fe73..22d9dca5224 100644
--- a/mps/design/protsu.txt
+++ b/mps/design/protsu.txt
@@ -131,8 +131,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/pthreadext.txt b/mps/design/pthreadext.txt
index 18b7b2d9d9f..b2d886b75a5 100644
--- a/mps/design/pthreadext.txt
+++ b/mps/design/pthreadext.txt
@@ -368,8 +368,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/range.txt b/mps/design/range.txt
index 9e6d4ce34a4..ee1e734ea40 100644
--- a/mps/design/range.txt
+++ b/mps/design/range.txt
@@ -124,8 +124,8 @@ Document history
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/root.txt b/mps/design/root.txt
index dd20868f3ed..11eb65565a6 100644
--- a/mps/design/root.txt
+++ b/mps/design/root.txt
@@ -97,8 +97,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/sig.txt b/mps/design/sig.txt
index 23f55a881a1..98ab1f489e0 100644
--- a/mps/design/sig.txt
+++ b/mps/design/sig.txt
@@ -177,8 +177,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/sp.txt b/mps/design/sp.txt
index 47dab436b4e..30c8fa62f35 100644
--- a/mps/design/sp.txt
+++ b/mps/design/sp.txt
@@ -186,8 +186,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/splay.txt b/mps/design/splay.txt
index 3a2ed9fd546..c1dfa8bb977 100644
--- a/mps/design/splay.txt
+++ b/mps/design/splay.txt
@@ -955,8 +955,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/ss.txt b/mps/design/ss.txt
index 8ecd6a18153..d81a0c7a4c2 100644
--- a/mps/design/ss.txt
+++ b/mps/design/ss.txt
@@ -132,8 +132,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/sso1al.txt b/mps/design/sso1al.txt
index bcf2905f198..e7f7065675e 100644
--- a/mps/design/sso1al.txt
+++ b/mps/design/sso1al.txt
@@ -153,8 +153,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/strategy.txt b/mps/design/strategy.txt
index 51b32e9e31a..97aa86a4a08 100644
--- a/mps/design/strategy.txt
+++ b/mps/design/strategy.txt
@@ -557,8 +557,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/telemetry.txt b/mps/design/telemetry.txt
index c19bbab0056..33ad9a4e38d 100644
--- a/mps/design/telemetry.txt
+++ b/mps/design/telemetry.txt
@@ -457,8 +457,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/tests.txt b/mps/design/tests.txt
index e1e9eb51e83..31cfffb0bf2 100644
--- a/mps/design/tests.txt
+++ b/mps/design/tests.txt
@@ -76,8 +76,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2016 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/testthr.txt b/mps/design/testthr.txt
index a1bf99bb247..86f545aa194 100644
--- a/mps/design/testthr.txt
+++ b/mps/design/testthr.txt
@@ -115,8 +115,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/thread-manager.txt b/mps/design/thread-manager.txt
index 88f2b2478fa..1d6d585a9d6 100644
--- a/mps/design/thread-manager.txt
+++ b/mps/design/thread-manager.txt
@@ -335,8 +335,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/thread-safety.txt b/mps/design/thread-safety.txt
index 826d008a596..9e3df1de20b 100644
--- a/mps/design/thread-safety.txt
+++ b/mps/design/thread-safety.txt
@@ -349,8 +349,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/trace.txt b/mps/design/trace.txt
index 236a0cae5d9..a2869145155 100644
--- a/mps/design/trace.txt
+++ b/mps/design/trace.txt
@@ -295,8 +295,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/type.txt b/mps/design/type.txt
index 008a54a209c..365de98b1a7 100644
--- a/mps/design/type.txt
+++ b/mps/design/type.txt
@@ -717,8 +717,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/version-library.txt b/mps/design/version-library.txt
index b679c382713..0afb604e690 100644
--- a/mps/design/version-library.txt
+++ b/mps/design/version-library.txt
@@ -133,8 +133,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/version.txt b/mps/design/version.txt
index 798c01ead99..15e661c9513 100644
--- a/mps/design/version.txt
+++ b/mps/design/version.txt
@@ -61,8 +61,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/vm.txt b/mps/design/vm.txt
index fb1be6eb5da..72babab8396 100644
--- a/mps/design/vm.txt
+++ b/mps/design/vm.txt
@@ -369,8 +369,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/vmo1.txt b/mps/design/vmo1.txt
index 33c90858439..2bb33a4f182 100644
--- a/mps/design/vmo1.txt
+++ b/mps/design/vmo1.txt
@@ -72,8 +72,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/vmso.txt b/mps/design/vmso.txt
index a73a0d65cbd..9a06c26950b 100644
--- a/mps/design/vmso.txt
+++ b/mps/design/vmso.txt
@@ -159,8 +159,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2014 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/mps/design/writef.txt b/mps/design/writef.txt
index 2a0277990e0..71792920102 100644
--- a/mps/design/writef.txt
+++ b/mps/design/writef.txt
@@ -158,8 +158,8 @@ Document History
 Copyright and License
 ---------------------
 
-Copyright © 2013-2015 Ravenbrook Limited. All rights reserved.
-<http://www.ravenbrook.com/>. This is an open source license. Contact
+Copyright © 2013-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
+All rights reserved. This is an open source license. Contact
 Ravenbrook for commercial licensing options.
 
 Redistribution and use in source and binary forms, with or without

From bcc567710b6a64fde83aab386c752dc78a510ff0 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 27 Mar 2016 20:48:38 +0100
Subject: [PATCH 68/69] Documenting and checking constraints on mps_key_align
 on manual pools.

Copied from Perforce
 Change: 190472
 ServerID: perforce.ravenbrook.com
---
 mps/code/apss.c                   | 26 ++++++++++++++++----------
 mps/code/poolmv.c                 |  5 ++++-
 mps/code/poolmv2.c                |  6 +++---
 mps/code/poolmvff.c               |  6 +++---
 mps/code/testlib.c                | 26 +++++++++++++++++++++-----
 mps/code/testlib.h                |  5 +++++
 mps/manual/source/pool/mv.rst     |  9 +++++----
 mps/manual/source/pool/mvff.rst   | 11 +++++------
 mps/manual/source/pool/mvt.rst    | 11 +++++------
 mps/manual/source/topic/arena.rst |  6 +++---
 10 files changed, 70 insertions(+), 41 deletions(-)

diff --git a/mps/code/apss.c b/mps/code/apss.c
index 79a029f86b1..e254323e380 100644
--- a/mps/code/apss.c
+++ b/mps/code/apss.c
@@ -169,13 +169,14 @@ static mps_pool_debug_option_s fenceOptions = {
  */
 
 static void test(mps_arena_class_t arena_class, mps_arg_s arena_args[],
+                 size_t arena_grain_size,
                  mps_pool_debug_option_s *options)
 {
   mps_arena_t arena;
   die(mps_arena_create_k(&arena, arena_class, arena_args), "mps_arena_create");
 
   MPS_ARGS_BEGIN(args) {
-    mps_align_t align = sizeof(void *) << (rnd() % 4);
+    mps_align_t align = rnd_align(sizeof(void *), arena_grain_size);
     MPS_ARGS_ADD(args, MPS_KEY_ALIGN, align);
     MPS_ARGS_ADD(args, MPS_KEY_MVFF_ARENA_HIGH, TRUE);
     MPS_ARGS_ADD(args, MPS_KEY_MVFF_SLOT_HIGH, TRUE);
@@ -189,14 +190,14 @@ static void test(mps_arena_class_t arena_class, mps_arg_s arena_args[],
   /* yet (MV Debug works here, because it fakes it through PoolAlloc). */
 
   MPS_ARGS_BEGIN(args) {
-    mps_align_t align = (mps_align_t)1 << (rnd() % 6);
+    mps_align_t align = rnd_align(sizeof(void *), arena_grain_size);
     MPS_ARGS_ADD(args, MPS_KEY_ALIGN, align);
     die(stress(arena, NULL, align, randomSizeAligned, "MV",
                mps_class_mv(), args), "stress MV");
   } MPS_ARGS_END(args);
 
   MPS_ARGS_BEGIN(args) {
-    mps_align_t align = (mps_align_t)1 << (rnd() % 6);
+    mps_align_t align = rnd_align(sizeof(void *), arena_grain_size);
     MPS_ARGS_ADD(args, MPS_KEY_ALIGN, align);
     MPS_ARGS_ADD(args, MPS_KEY_POOL_DEBUG_OPTIONS, options);
     die(stress(arena, options, align, randomSizeAligned, "MV debug",
@@ -204,7 +205,7 @@ static void test(mps_arena_class_t arena_class, mps_arg_s arena_args[],
   } MPS_ARGS_END(args);
 
   MPS_ARGS_BEGIN(args) {
-    mps_align_t align = sizeof(void *) << (rnd() % 4);
+    mps_align_t align = rnd_align(sizeof(void *), arena_grain_size);
     MPS_ARGS_ADD(args, MPS_KEY_ALIGN, align);
     die(stress(arena, NULL, align, randomSizeAligned, "MVT",
                mps_class_mvt(), args), "stress MVT");
@@ -218,28 +219,33 @@ static void test(mps_arena_class_t arena_class, mps_arg_s arena_args[],
 
 int main(int argc, char *argv[])
 {
+  size_t arena_grain_size;
+  
   testlib_init(argc, argv);
 
+  arena_grain_size = rnd_grain(2 * testArenaSIZE);
   MPS_ARGS_BEGIN(args) {
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, 2 * testArenaSIZE);
-    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, rnd_grain(2*testArenaSIZE));
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
     MPS_ARGS_ADD(args, MPS_KEY_COMMIT_LIMIT, testArenaSIZE);
-    test(mps_arena_class_vm(), args, &fenceOptions);
+    test(mps_arena_class_vm(), args, arena_grain_size, &fenceOptions);
   } MPS_ARGS_END(args);
 
+  arena_grain_size = rnd_grain(2 * testArenaSIZE);
   MPS_ARGS_BEGIN(args) {
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, 2 * testArenaSIZE);
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, FALSE);
-    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, rnd_grain(2*testArenaSIZE));
-    test(mps_arena_class_vm(), args, &bothOptions);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
+    test(mps_arena_class_vm(), args, arena_grain_size, &bothOptions);
   } MPS_ARGS_END(args);
 
+  arena_grain_size = rnd_grain(testArenaSIZE);
   MPS_ARGS_BEGIN(args) {
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, testArenaSIZE);
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, FALSE);
     MPS_ARGS_ADD(args, MPS_KEY_ARENA_CL_BASE, malloc(testArenaSIZE));
-    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, rnd_grain(testArenaSIZE));
-    test(mps_arena_class_cl(), args, &bothOptions);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
+    test(mps_arena_class_cl(), args, arena_grain_size, &bothOptions);
   } MPS_ARGS_END(args);
 
   printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
diff --git a/mps/code/poolmv.c b/mps/code/poolmv.c
index 719cba6d7df..f3ef16f69ee 100644
--- a/mps/code/poolmv.c
+++ b/mps/code/poolmv.c
@@ -29,6 +29,7 @@
 #include "dbgpool.h"
 #include "poolmv.h"
 #include "poolmfs.h"
+#include "mpscmvff.h"
 #include "mpm.h"
 
 SRCID(poolmv, "$Id$");
@@ -236,7 +237,10 @@ static Res MVInit(Pool pool, ArgList args)
   if (ArgPick(&arg, args, MPS_KEY_MAX_SIZE))
     maxSize = arg.val.size;
 
+  arena = PoolArena(pool);
+
   AVERT(Align, align);
+  AVER(align <= ArenaGrainSize(arena));
   AVER(extendBy > 0);
   AVER(avgSize > 0);
   AVER(avgSize <= extendBy);
@@ -245,7 +249,6 @@ static Res MVInit(Pool pool, ArgList args)
 
   pool->alignment = align;
   mv = PoolMV(pool);
-  arena = PoolArena(pool);
 
   /* At 100% fragmentation we will need one block descriptor for every other */
   /* allocated block, or (extendBy/avgSize)/2 descriptors.  See note 1. */
diff --git a/mps/code/poolmv2.c b/mps/code/poolmv2.c
index dc352d6eb81..fbfb8464e61 100644
--- a/mps/code/poolmv2.c
+++ b/mps/code/poolmv2.c
@@ -259,10 +259,10 @@ static Res MVTInit(Pool pool, ArgList args)
 
   AVERT(Align, align);
   /* This restriction on the alignment is necessary because of the use
-   * of a Freelist to store the free address ranges in low-memory
-   * situations. See <design/freelist/#impl.grain.align>.
-   */
+     of a Freelist to store the free address ranges in low-memory
+     situations. See <design/freelist/#impl.grain.align>. */
   AVER(AlignIsAligned(align, FreelistMinimumAlignment));
+  AVER(align <= ArenaGrainSize(arena));
   AVER(0 < minSize);
   AVER(minSize <= meanSize);
   AVER(meanSize <= maxSize);
diff --git a/mps/code/poolmvff.c b/mps/code/poolmvff.c
index 82d5c072ff3..64acc2606ab 100644
--- a/mps/code/poolmvff.c
+++ b/mps/code/poolmvff.c
@@ -486,10 +486,10 @@ static Res MVFFInit(Pool pool, ArgList args)
   AVER(spare <= 1.0);           /* .arg.check */
   AVERT(Align, align);
   /* This restriction on the alignment is necessary because of the use
-   * of a Freelist to store the free address ranges in low-memory
-   * situations. <design/freelist/#impl.grain.align>.
-   */
+     of a Freelist to store the free address ranges in low-memory
+     situations. <design/freelist/#impl.grain.align>. */
   AVER(AlignIsAligned(align, FreelistMinimumAlignment));
+  AVER(align <= ArenaGrainSize(arena));
   AVERT(Bool, slotHigh);
   AVERT(Bool, arenaHigh);
   AVERT(Bool, firstFit);
diff --git a/mps/code/testlib.c b/mps/code/testlib.c
index 401c4059938..af96d3643fb 100644
--- a/mps/code/testlib.c
+++ b/mps/code/testlib.c
@@ -220,14 +220,30 @@ double rnd_double(void)
   return rnd() / R_m_float;
 }
 
+static unsigned sizelog2(size_t size)
+{
+  return (unsigned)(log((double)size) / log(2.0));
+}
+
 size_t rnd_grain(size_t arena_size)
 {
   /* The grain size must be small enough to allow for a complete set
-   * of zones in the initial chunk. */
-  size_t s = (size_t)(log((double)arena_size) / log(2.0));
-  size_t shift = MPS_WORD_SHIFT;
-  Insist(s > shift);
-  return (size_t)1 << (rnd() % (s - shift));
+     of zones in the initial chunk, but bigger than one word. */
+  Insist(arena_size >> MPS_WORD_SHIFT >= sizeof(void *));
+  return rnd_align(sizeof(void *), (size_t)1 << sizelog2(arena_size >> MPS_WORD_SHIFT));
+}
+
+size_t rnd_align(size_t min, size_t max)
+{
+  unsigned log2min = sizelog2(min);
+  unsigned log2max = sizelog2(max);
+  Insist(min <= max);
+  Insist(1uL << log2min == min);
+  Insist(1uL << log2max == max);
+  if (log2min < log2max)
+    return min << (rnd() % (log2max - log2min + 1));
+  else
+    return min;
 }
 
 rnd_state_t rnd_seed(void)
diff --git a/mps/code/testlib.h b/mps/code/testlib.h
index 0b5b7160165..0492aaf138b 100644
--- a/mps/code/testlib.h
+++ b/mps/code/testlib.h
@@ -260,6 +260,11 @@ extern double rnd_double(void);
 extern size_t rnd_grain(size_t arena_size);
 
 
+/* rnd_align -- random alignment */
+
+extern size_t rnd_align(size_t min, size_t max);
+
+
 /* randomize -- randomize the generator, or initialize to replay
  *
  * randomize(argc, argv) randomizes the rnd generator (using time(3))
diff --git a/mps/manual/source/pool/mv.rst b/mps/manual/source/pool/mv.rst
index 27e691ed3af..b8cfb08d2ea 100644
--- a/mps/manual/source/pool/mv.rst
+++ b/mps/manual/source/pool/mv.rst
@@ -70,10 +70,11 @@ MV interface
     optional :term:`keyword arguments`:
 
     * :c:macro:`MPS_KEY_ALIGN` (type :c:type:`mps_align_t`, default is
-      :c:macro:`MPS_PF_ALIGN`) is the
-      :term:`alignment` of addresses for allocation (and freeing) in
-      the pool. If an unaligned size is passed to :c:func:`mps_alloc` or
-      :c:func:`mps_free`, it will be rounded up to the pool's alignment.
+      :c:macro:`MPS_PF_ALIGN`) is the :term:`alignment` of the
+      addresses allocated (and freed) in the pool. The minimum
+      alignment supported by pools of this class is 1 (one)
+      and the maximum is the arena grain size
+      (see :c:macro:`MPS_KEY_ARENA_GRAIN_SIZE`).
 
     * :c:macro:`MPS_KEY_EXTEND_BY` (type :c:type:`size_t`,
       default 65536) is the :term:`size` of block that the pool will
diff --git a/mps/manual/source/pool/mvff.rst b/mps/manual/source/pool/mvff.rst
index 04a7d48603d..fd890f17dc9 100644
--- a/mps/manual/source/pool/mvff.rst
+++ b/mps/manual/source/pool/mvff.rst
@@ -115,12 +115,11 @@ MVFF interface
       efficient if this is wrong, but nothing will break.
 
     * :c:macro:`MPS_KEY_ALIGN` (type :c:type:`mps_align_t`, default is
-      :c:macro:`MPS_PF_ALIGN`) is the
-      :term:`alignment` of addresses for allocation (and freeing) in
-      the pool. If an unaligned size is passed to :c:func:`mps_alloc`
-      or :c:func:`mps_free`, it will be rounded up to the pool's
-      alignment. The minimum alignment supported by pools of this
-      class is ``sizeof(void *)``.
+      :c:macro:`MPS_PF_ALIGN`) is the :term:`alignment` of the
+      addresses allocated (and freed) in the pool. The minimum
+      alignment supported by pools of this class is ``sizeof(void *)``
+      and the maximum is the arena grain size
+      (see :c:macro:`MPS_KEY_ARENA_GRAIN_SIZE`).
 
     * :c:macro:`MPS_KEY_SPARE` (type :c:type:`double`, default 0.75)
       is the maximum proportion of memory that the pool will keep
diff --git a/mps/manual/source/pool/mvt.rst b/mps/manual/source/pool/mvt.rst
index da2ce024baa..8973823f948 100644
--- a/mps/manual/source/pool/mvt.rst
+++ b/mps/manual/source/pool/mvt.rst
@@ -115,12 +115,11 @@ MVT interface
     optional :term:`keyword arguments`:
 
     * :c:macro:`MPS_KEY_ALIGN` (type :c:type:`mps_align_t`, default is
-      :c:macro:`MPS_PF_ALIGN`) is the
-      :term:`alignment` of addresses for allocation (and freeing) in
-      the pool. If an unaligned size is passed to :c:func:`mps_alloc` or
-      :c:func:`mps_free`, it will be rounded up to the pool's alignment.
-      The minimum alignment supported by pools of this class is
-      ``sizeof(void *)``.
+      :c:macro:`MPS_PF_ALIGN`) is the :term:`alignment` of the
+      addresses allocated (and freed) in the pool. The minimum
+      alignment supported by pools of this class is ``sizeof(void *)``
+      and the maximum is the arena grain size
+      (see :c:macro:`MPS_KEY_ARENA_GRAIN_SIZE`).
 
     * :c:macro:`MPS_KEY_MIN_SIZE` (type :c:type:`size_t`, default is
       :c:macro:`MPS_PF_ALIGN`) is the
diff --git a/mps/manual/source/topic/arena.rst b/mps/manual/source/topic/arena.rst
index 2d6b99ca0db..d538402cba9 100644
--- a/mps/manual/source/topic/arena.rst
+++ b/mps/manual/source/topic/arena.rst
@@ -150,9 +150,9 @@ Client arenas
 
     * :c:macro:`MPS_KEY_ARENA_GRAIN_SIZE` (type :c:type:`size_t`,
       default 8192) is the granularity with which the arena will
-      manage memory internally. It must be a power of 2. Larger
-      granularity reduces overheads, but increases
-      :term:`fragmentation` and :term:`retention`.
+      manage memory internally. It must be a power of 2, and at least
+      ``sizeof(void *)``. Larger granularity reduces overheads, but
+      increases :term:`fragmentation` and :term:`retention`.
 
     * :c:macro:`MPS_KEY_PAUSE_TIME` (type :c:type:`double`, default
       0.1) is the maximum time, in seconds, that operations within the

From e67a9934f174bd62c3c4fe01bc0e66ad05d40289 Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Sun, 27 Mar 2016 21:17:53 +0100
Subject: [PATCH 69/69] Cross-referencing comment about non-working debugging
 aps to job003995.

Copied from Perforce
 Change: 190477
 ServerID: perforce.ravenbrook.com
---
 mps/code/apss.c | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/mps/code/apss.c b/mps/code/apss.c
index e254323e380..7f579e54dda 100644
--- a/mps/code/apss.c
+++ b/mps/code/apss.c
@@ -186,8 +186,9 @@ static void test(mps_arena_class_t arena_class, mps_arg_s arena_args[],
                mps_class_mvff(), args), "stress MVFF");
   } MPS_ARGS_END(args);
 
-  /* IWBN to test MVFFDebug, but the MPS doesn't support debugging APs, */
-  /* yet (MV Debug works here, because it fakes it through PoolAlloc). */
+  /* IWBN to test MVFFDebug, but the MPS doesn't support debugging
+     APs, yet (MV Debug works here, because it fakes it through
+     PoolAlloc).  See job003995. */
 
   MPS_ARGS_BEGIN(args) {
     mps_align_t align = rnd_align(sizeof(void *), arena_grain_size);