Condemn only visits segments in condemned zones.

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

mps/code/arena.c

@@ -240,7 +240,7 @@ Res ArenaInit(Arena arena, ArenaClass class, Size grainSize, ArgList args)
   SplayTreeInit(ArenaSegSplay(arena),
                 SegCompare,
                 SegKey,
-                SplayTrivUpdate);
+                SegUpdate);
   
   LocusInit(arena);
   

mps/code/mpm.h

@@ -678,6 +678,7 @@ extern Bool SegOfAddr(Seg *segReturn, Arena arena, Addr addr);
 typedef Bool (*SegVisitor)(Seg seg, void *closure);
 extern Bool SegTraverse(Arena arena, SegVisitor visit, void *closure);
 extern void SegTraverseAndDelete(Arena arena, SegVisitor visit, void *closure);
+extern Bool SegTraverseInZones(Arena arena, ZoneSet zs, SegVisitor visit, void *closure);
 extern Bool SegFirst(Seg *segReturn, Arena arena);
 extern Bool SegNext(Seg *segReturn, Arena arena, Seg seg);
 extern Bool SegNextOfRing(Seg *segReturn, Arena arena, Pool pool, Ring next);
@@ -699,6 +700,7 @@ extern SegClass GCSegClassGet(void);
 extern void SegClassMixInNoSplitMerge(SegClass class);
 extern Compare SegCompare(Tree tree, TreeKey key);
 extern TreeKey SegKey(Tree tree);
+extern void SegUpdate(SplayTree splay, Tree tree);
 
 
 /* DEFINE_SEG_CLASS -- define a segment class */

mps/code/mpmst.h

@@ -241,6 +241,7 @@ typedef struct SegStruct {      /* segment structure */
   Pool pool;                    /* pool that owns this segment */
   RingStruct poolRing;          /* link in list of segs in pool */
   TreeStruct treeStruct;        /* tree of all segments by address */
+  ZoneSet treeZones;            /* union of all zones in sub-tree */
   unsigned depth : ShieldDepthWIDTH; /* see <code/shield.c#def.depth> */
   AccessSet pm : AccessLIMIT;   /* protection mode, <code/shield.c> */
   AccessSet sm : AccessLIMIT;   /* shield mode, <code/shield.c> */

mps/code/seg.c

@@ -162,6 +162,7 @@ static Res SegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
   seg->depth = 0;
   RingInit(SegPoolRing(seg));
   TreeInit(SegTree(seg));
+  seg->treeZones = ZoneSetEMPTY; /* set by SegUpdate */
   seg->sig = SegSig;  /* set sig now so tract checks will see it */
 
   /* Class specific initialization comes last */
@@ -253,6 +254,25 @@ TreeKey SegKey(Tree tree)
   return (TreeKey)SegBase(segOfTree(tree)); /* FIXME: See cbsBlockKey in cbs.c */
 }
 
+void SegUpdate(SplayTree splay, Tree tree)
+{
+  Seg seg = segOfTree(tree);
+  ZoneSet zones;
+  
+  UNUSED(splay);
+  AVERT_CRITICAL(Seg, seg);
+
+  /* FIXME: Duplicate code with cbsUpdateZonedNode. */
+  zones = ZoneSetOfRange(PoolArena(SegPool(seg)),
+                         SegBase(seg), SegLimit(seg));
+  if (TreeHasLeft(tree))
+    zones = ZoneSetUnion(zones, segOfTree(TreeLeft(tree))->treeZones);
+  if (TreeHasRight(tree))
+    zones = ZoneSetUnion(zones, segOfTree(TreeRight(tree))->treeZones);
+
+  seg->treeZones = zones;
+}
+
 
 /* SegSetGrey -- change the greyness of a segment
  *
@@ -466,6 +486,7 @@ Bool SegOfAddr(Seg *segReturn, Arena arena, Addr addr)
 
 typedef struct SegTraverseClosureStruct {
   SegVisitor visit;
+  ZoneSet zs;
   void *closure;
 } SegTraverseClosureStruct, *SegTraverseClosure;
 
@@ -475,17 +496,38 @@ static Bool segTraverseVisit(Tree tree, void *closure)
   return stv->visit(segOfTree(tree), stv->closure);
 }
 
+static Bool segTraverseFilter(Tree tree, void *closure)
+{
+  SegTraverseClosure stv = closure;
+  return ZoneSetInter(segOfTree(tree)->treeZones, stv->zs) != ZoneSetEMPTY;
+}
+
 Bool SegTraverse(Arena arena, SegVisitor visit, void *closure)
 {
   SegTraverseClosureStruct stvStruct;
   stvStruct.visit = visit;
   stvStruct.closure = closure;
+  stvStruct.zs = ZoneSetUNIV; /* not used */
   return TreeTraverse(SplayTreeRoot(ArenaSegSplay(arena)),
                       SegCompare, SegKey,
                       segTraverseVisit,
                       &stvStruct);
 }
 
+Bool SegTraverseInZones(Arena arena, ZoneSet zs, SegVisitor visit, void *closure)
+{
+  SegTraverseClosureStruct stvStruct;
+  stvStruct.visit = visit;
+  stvStruct.closure = closure;
+  stvStruct.zs = zs;
+  return TreeTraversePartial(SplayTreeRoot(ArenaSegSplay(arena)),
+                             SegCompare, SegKey,
+                             segTraverseFilter,
+                             TreeNoRange,
+                             segTraverseVisit,
+                             &stvStruct);
+}
+
 void SegTraverseAndDelete(Arena arena, SegVisitor visit, void *closure)
 {
   SegTraverseClosureStruct stvStruct;

mps/code/trace.c

@@ -484,7 +484,8 @@ Res TraceCondemnZones(Trace trace, ZoneSet condemnedSet)
   tczStruct.condemnedSet = condemnedSet;
   tczStruct.haveWhiteSegs = FALSE;
   tczStruct.res = ResOK;
-  if (!SegTraverse(trace->arena, traceCondemnZonesVisit, &tczStruct)) {
+  if (!SegTraverseInZones(trace->arena, condemnedSet,
+                          traceCondemnZonesVisit, &tczStruct)) {
     AVER(tczStruct.res != ResOK);
     AVER(TraceIsEmpty(trace)); /* See .whiten.fail. */
     return tczStruct.res;
@@ -975,6 +976,12 @@ static void traceReclaim(Trace trace)
 
   /* TODO: This isn't very nice, as it rebalances the segment splay
      tree and destroys any optimisation discovered by splaying. */
+  /* TODO: This isn't very nice, as it visits every segment,
+     regardless of colour or zone. */
+  /* TODO: Consider sort | uniq the white table? */
+  /* TODO: For multiple traces, the white table is shared, and so we
+     must delete the pages of reclaimed segments from it.  That means
+     visiting the table might work. */
   SegTraverseAndDelete(arena, traceReclaimVisit, trace);
 
   trace->state = TraceFINISHED;