Fixing deep checking and shield checking

.github/workflows/build-and-test.yml

@@ -66,6 +66,16 @@ jobs:
          nmake /f w3i6mv.nmk all testci testansi testpollnone
       shell: cmd
 
+  # See design.mps.tests.ci.run.other.deep.
+  deep-check:
+
+    runs-on: ubuntu-latest
+
+    steps:
+      - uses: actions/checkout@v3
+      - run: ./configure
+      - run: make test-make-build-deep
+
 
 # A. REFERENCES
 #

Makefile.in

@@ -79,6 +79,9 @@ test-make-build:
 	$(MAKE) -C code -f anan$(MPS_BUILD_NAME).gmk VARIETY=cool clean testansi
 	$(MAKE) -C code -f anan$(MPS_BUILD_NAME).gmk VARIETY=cool CFLAGS="-DCONFIG_POLL_NONE" clean testpollnone
 
+test-make-build-deep:
+	$(MAKE) $(TARGET_OPTS) VARIETY=cool CFLAGS='-DCHECKLEVEL=CheckLevelDEEP' testci
+
 test-xcode-build:
 	$(XCODEBUILD) -config Debug   -target testci
 	$(XCODEBUILD) -config Release -target testci
@@ -88,7 +91,7 @@ test: @TEST_TARGET@
 
 # C. COPYRIGHT AND LICENSE
 #
-# Copyright (C) 2012-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+# Copyright (C) 2012-2023 Ravenbrook Limited <https://www.ravenbrook.com/>.
 #
 # Redistribution and use in source and binary forms, with or without
 # modification, are permitted provided that the following conditions are

code/dbgpool.c

@@ -356,12 +356,12 @@ static void debugPoolSegIterate(Arena arena, Addr base, Addr limit,
 
 static void debugPoolShieldExpose(Arena arena, Seg seg)
 {
-  ShieldExpose(arena, seg);
+  ShieldExpose(ArenaShield(arena), seg);
 }
 
 static void debugPoolShieldCover(Arena arena, Seg seg)
 {
-  ShieldCover(arena, seg);
+  ShieldCover(ArenaShield(arena), seg);
 }
 
 

code/global.c

@@ -78,7 +78,7 @@ void GlobalsReleaseAll(void)
 static void arenaReinitLock(Arena arena)
 {
   AVERT(Arena, arena);
-  ShieldLeave(arena);
+  ShieldLeave(ArenaShield(arena));
   LockInit(ArenaGlobals(arena)->lock);
 }
 
@@ -579,7 +579,7 @@ void ArenaEnterLock(Arena arena, Bool recursive)
   if(recursive) {
     /* already in shield */
   } else {
-    ShieldEnter(arena);
+    ShieldEnter(ArenaShield(arena));
   }
 }
 
@@ -611,7 +611,7 @@ void ArenaLeaveLock(Arena arena, Bool recursive)
   if(recursive) {
     /* no need to leave shield */
   } else {
-    ShieldLeave(arena);
+    ShieldLeave(ArenaShield(arena));
   }
   ProtSync(arena);              /* <design/prot#.if.sync> */
   if(recursive) {
@@ -917,9 +917,9 @@ Ref ArenaPeekSeg(Arena arena, Seg seg, Ref *p)
   /* We don't need to update the Seg Summary as in PoolSingleAccess
    * because we are not changing it after it has been scanned. */
 
-  ShieldExpose(arena, seg);
+  ShieldExpose(ArenaShield(arena), seg);
   ref = *p;
-  ShieldCover(arena, seg);
+  ShieldCover(ArenaShield(arena), seg);
   return ref;
 }
 
@@ -953,12 +953,12 @@ void ArenaPokeSeg(Arena arena, Seg seg, Ref *p, Ref ref)
   /* TODO: Consider checking p's alignment using seg->pool->alignment */
   /* ref is arbitrary and can't be checked */
 
-  ShieldExpose(arena, seg);
+  ShieldExpose(ArenaShield(arena), seg);
   *p = ref;
   summary = SegSummary(seg);
   summary = RefSetAdd(arena, summary, (Addr)ref);
   SegSetSummary(seg, summary);
-  ShieldCover(arena, seg);
+  ShieldCover(ArenaShield(arena), seg);
 }
 
 /* ArenaRead -- like ArenaPeek, but reference known to be owned by arena */

code/ld.c

@@ -149,11 +149,11 @@ void LDReset(mps_ld_t ld, Arena arena)
 
   b = SegOfAddr(&seg, arena, (Addr)ld);
   if (b)
-    ShieldExpose(arena, seg);   /* .ld.access */
+    ShieldExpose(ArenaShield(arena), seg);   /* .ld.access */
   ld->_epoch = ArenaHistory(arena)->epoch;
   ld->_rs = RefSetEMPTY;
   if (b)
-    ShieldCover(arena, seg);
+    ShieldCover(ArenaShield(arena), seg);
 }
 
 

code/mpm.h

@@ -872,37 +872,38 @@ extern ZoneSet ZoneSetBlacklist(Arena arena);
 
 /* Shield Interface -- see <code/shield.c> */
 
+#define ShieldArena(shield) PARENT(ArenaStruct, shieldStruct, shield)
 extern void ShieldInit(Shield shield);
 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);
-extern void (ShieldLeave)(Arena arena);
-extern void (ShieldExpose)(Arena arena, Seg seg);
-extern void (ShieldCover)(Arena arena, Seg seg);
-extern void (ShieldHold)(Arena arena);
-extern void (ShieldRelease)(Arena arena);
-extern void (ShieldFlush)(Arena arena);
+extern void (ShieldRaise)(Shield shield, Seg seg, AccessSet mode);
+extern void (ShieldLower)(Shield shield, Seg seg, AccessSet mode);
+extern void (ShieldEnter)(Shield shield);
+extern void (ShieldLeave)(Shield shield);
+extern void (ShieldExpose)(Shield shield, Seg seg);
+extern void (ShieldCover)(Shield shield, Seg seg);
+extern void (ShieldHold)(Shield shield);
+extern void (ShieldRelease)(Shield shield);
+extern void (ShieldFlush)(Shield shield);
 
 #if defined(SHIELD)
 /* Nothing to do: functions declared in all shield configurations. */
 #elif defined(SHIELD_NONE)
-#define ShieldRaise(arena, seg, mode) \
-  BEGIN UNUSED(arena); UNUSED(seg); UNUSED(mode); END
-#define ShieldLower(arena, seg, mode) \
-  BEGIN UNUSED(arena); UNUSED(seg); UNUSED(mode); END
-#define ShieldEnter(arena) BEGIN UNUSED(arena); END
-#define ShieldLeave(arena) AVER(arena->busyTraces == TraceSetEMPTY)
-#define ShieldExpose(arena, seg)  \
-  BEGIN UNUSED(arena); UNUSED(seg); END
-#define ShieldCover(arena, seg) \
-  BEGIN UNUSED(arena); UNUSED(seg); END
-#define ShieldHold(arena) BEGIN UNUSED(arena); END
-#define ShieldRelease(arena) BEGIN UNUSED(arena); END
-#define ShieldFlush(arena) BEGIN UNUSED(arena); END
+#define ShieldRaise(shield, seg, mode) \
+  BEGIN UNUSED(shield); UNUSED(seg); UNUSED(mode); END
+#define ShieldLower(shield, seg, mode) \
+  BEGIN UNUSED(shield); UNUSED(seg); UNUSED(mode); END
+#define ShieldEnter(shield) BEGIN UNUSED(shield); END
+#define ShieldLeave(shield) AVER(ShieldArena(shield)->busyTraces == TraceSetEMPTY)
+#define ShieldExpose(shield, seg)  \
+  BEGIN UNUSED(shield); UNUSED(seg); END
+#define ShieldCover(shield, seg) \
+  BEGIN UNUSED(shield); UNUSED(seg); END
+#define ShieldHold(shield) BEGIN UNUSED(shield); END
+#define ShieldRelease(shield) BEGIN UNUSED(shield); END
+#define ShieldFlush(shield) BEGIN UNUSED(shield); END
 #else
 #error "No shield configuration."
 #endif  /* SHIELD */

code/mpmst.h

@@ -669,13 +669,14 @@ typedef struct ShieldStruct {
   Sig sig;           /* design.mps.sig.field */
   BOOLFIELD(inside); /* <design/shield#.def.inside> */
   BOOLFIELD(suspended); /* mutator suspended? */
-  BOOLFIELD(queuePending); /* queue insertion pending? */
   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 */
   Count unsynced;    /* number of unsynced segments */
+  Count unqueued;    /* number of unsynced unqueued segments */
+  Count synced;      /* number of synced queued segments */
   Count holds;       /* number of holds */
   SortStruct sortStruct; /* workspace for queue sort */
 } ShieldStruct;

code/poolamc.c

@@ -985,9 +985,9 @@ static Res AMCBufferFill(Addr *baseReturn, Addr *limitReturn,
     AVER(SizeIsAligned(padSize, PoolAlignment(pool)));
     AVER(AddrAdd(limit, padSize) == SegLimit(seg));
     if(padSize > 0) {
-      ShieldExpose(arena, seg);
+      ShieldExpose(ArenaShield(arena), seg);
       (*pool->format->pad)(limit, padSize);
-      ShieldCover(arena, seg);
+      ShieldCover(ArenaShield(arena), seg);
     }
   }
 
@@ -1032,9 +1032,9 @@ static void amcSegBufferEmpty(Seg seg, Buffer buffer)
 
   /* <design/poolamc#.flush.pad> */
   if (init < limit) {
-    ShieldExpose(arena, seg);
+    ShieldExpose(ArenaShield(arena), seg);
     (*pool->format->pad)(init, AddrOffset(init, limit));
-    ShieldCover(arena, seg);
+    ShieldCover(ArenaShield(arena), seg);
   }
 
   /* Any allocation in the buffer (including the padding object just
@@ -1508,9 +1508,9 @@ static Res amcSegFixEmergency(Seg seg, ScanState ss, Ref *refIO)
   if(ss->rank == RankAMBIG)
     goto fixInPlace;
 
-  ShieldExpose(arena, seg);
+  ShieldExpose(ArenaShield(arena), seg);
   newRef = (*pool->format->isMoved)(*refIO);
-  ShieldCover(arena, seg);
+  ShieldCover(ArenaShield(arena), seg);
   if(newRef != (Addr)0) {
     /* Object has been forwarded already, so snap-out pointer. */
     /* TODO: Implement weak pointer semantics in emergency fixing.  This
@@ -1592,7 +1592,7 @@ static Res amcSegFix(Seg seg, ScanState ss, Ref *refIO)
 
   /* .exposed.seg: Statements tagged ".exposed.seg" below require */
   /* that "seg" (that is: the 'from' seg) has been ShieldExposed. */
-  ShieldExpose(arena, seg);
+  ShieldExpose(ArenaShield(arena), seg);
   newRef = (*format->isMoved)(ref);  /* .exposed.seg */
 
   if(newRef == (Addr)0) {
@@ -1637,7 +1637,7 @@ static Res amcSegFix(Seg seg, ScanState ss, Ref *refIO)
       newRef = AddrAdd(newBase, headerSize);
 
       toSeg = BufferSeg(buffer);
-      ShieldExpose(arena, toSeg);
+      ShieldExpose(ArenaShield(arena), toSeg);
 
       /* Since we're moving an object from one segment to another, */
       /* union the greyness and the summaries together. */
@@ -1653,7 +1653,7 @@ static Res amcSegFix(Seg seg, ScanState ss, Ref *refIO)
       /* <design/trace#.fix.copy> */
       (void)AddrCopy(newBase, base, length);  /* .exposed.seg */
 
-      ShieldCover(arena, toSeg);
+      ShieldCover(ArenaShield(arena), toSeg);
     } while (!BUFFER_COMMIT(buffer, newBase, length));
 
     STATISTIC(ss->copiedSize += length);
@@ -1675,7 +1675,7 @@ static Res amcSegFix(Seg seg, ScanState ss, Ref *refIO)
   res = ResOK;
 
 returnRes:
-  ShieldCover(arena, seg);  /* .exposed.seg */
+  ShieldCover(ArenaShield(arena), seg);  /* .exposed.seg */
   return res;
 }
 
@@ -1706,7 +1706,7 @@ static void amcSegReclaimNailed(Pool pool, Trace trace, Seg seg)
 
   /* see <design/poolamc#.nailboard.limitations> for improvements */
   headerSize = format->headerSize;
-  ShieldExpose(arena, seg);
+  ShieldExpose(ArenaShield(arena), seg);
   p = SegBase(seg);
   limit = SegBufferScanLimit(seg);
   padBase = p;
@@ -1753,7 +1753,7 @@ static void amcSegReclaimNailed(Pool pool, Trace trace, Seg seg)
     (*format->pad)(padBase, padLength);
     STATISTIC(bytesReclaimed += padLength);
   }
-  ShieldCover(arena, seg);
+  ShieldCover(ArenaShield(arena), seg);
 
   SegSetNailed(seg, TraceSetDel(SegNailed(seg), trace));
   SegSetWhite(seg, TraceSetDel(SegWhite(seg), trace));
@@ -1887,9 +1887,9 @@ static void amcWalkAll(Pool pool, FormattedObjectsVisitor f, void *p, size_t s)
   RING_FOR(node, ring, next) {
     Seg seg = SegOfPoolRing(node);
 
-    ShieldExpose(arena, seg);
+    ShieldExpose(ArenaShield(arena), seg);
     amcSegWalk(seg, format, f, p, s);
-    ShieldCover(arena, seg);
+    ShieldCover(ArenaShield(arena), seg);
   }
 }
 

code/poolams.c

@@ -1491,10 +1491,11 @@ static Res amsSegFix(Seg seg, ScanState ss, Ref *refIO)
         if (SegRankSet(seg) == RankSetEMPTY && ss->rank != RankAMBIG) {
           /* <design/poolams#.fix.to-black> */
           Addr clientNext, next;
+	  Shield shield = ArenaShield(PoolArena(pool));
 
-          ShieldExpose(PoolArena(pool), seg);
+          ShieldExpose(shield, seg);
           clientNext = (*pool->format->skip)(clientRef);
-          ShieldCover(PoolArena(pool), seg);
+          ShieldCover(shield, seg);
           next = AddrSub(clientNext, format->headerSize);
           /* Part of the object might be grey, because of ambiguous */
           /* fixes, but that's OK, because scan will ignore that. */

code/poolawl.c

@@ -869,15 +869,15 @@ static Res awlScanObject(Arena arena, AWL awl, ScanState ss,
   dependent = SegOfAddr(&dependentSeg, arena, dependentObject);
   if (dependent) {
       /* <design/poolawl#.fun.scan.pass.object.dependent.expose> */
-      ShieldExpose(arena, dependentSeg);
+    ShieldExpose(ArenaShield(arena), dependentSeg);
       /* <design/poolawl#.fun.scan.pass.object.dependent.summary> */
       SegSetSummary(dependentSeg, RefSetUNIV);
   }
 
   res = TraceScanFormat(ss, base, limit);
 
   if (dependent)
-    ShieldCover(arena, dependentSeg);
+    ShieldCover(ArenaShield(arena), dependentSeg);
 
   return res;
 }

code/poolmrg.c

@@ -829,13 +829,13 @@ static Res MRGDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
     Bool outsideShield = !ArenaShield(arena)->inside;
     refPart = MRGRefPartOfLink(linkOfRing(node), arena);
     if (outsideShield) {
-      ShieldEnter(arena);
+      ShieldEnter(ArenaShield(arena));
     }
     res = WriteF(stream, depth + 2, "at $A Ref $A\n",
                  (WriteFA)refPart, (WriteFA)MRGRefPartRef(arena, refPart),
                  NULL);
     if (outsideShield) {
-      ShieldLeave(arena);
+      ShieldLeave(ArenaShield(arena));
     }
     if (res != ResOK)
       return res;

code/poolsnc.c

@@ -287,9 +287,9 @@ static void sncRecordFreeSeg(Arena arena, SNC snc, Seg seg)
   SegSetRankAndSummary(seg, RankSetEMPTY, RefSetEMPTY);
 
   /* Pad the whole segment so we don't try to walk it. */
-  ShieldExpose(arena, seg);
+  ShieldExpose(ArenaShield(arena), seg);
   (*SNCPool(snc)->format->pad)(SegBase(seg), SegSize(seg));
-  ShieldCover(arena, seg);
+  ShieldCover(ArenaShield(arena), seg);
 
   sncSegSetNext(seg, snc->freeSegs);
   snc->freeSegs = seg;
@@ -498,9 +498,9 @@ static void sncSegBufferEmpty(Seg seg, Buffer buffer)
 
   /* Pad the unused space at the end of the segment */
   if (init < limit) {
-    ShieldExpose(arena, seg);
+    ShieldExpose(ArenaShield(arena), seg);
     (*pool->format->pad)(init, AddrOffset(init, limit));
-    ShieldCover(arena, seg);
+    ShieldCover(ArenaShield(arena), seg);
   }
 }
 

code/protan.c

@@ -60,9 +60,9 @@ void ProtSync(Arena arena)
     if (SegFirst(&seg, arena)) {
       do {
         if (SegPM(seg) != AccessSetEMPTY) { /* <design/protan#.fun.sync.seg> */
-          ShieldEnter(arena);
+          ShieldEnter(ArenaShield(arena));
           TraceSegAccess(arena, seg, SegPM(seg));
-          ShieldLeave(arena);
+          ShieldLeave(ArenaShield(arena));
           synced = FALSE;
         }
       } while(SegNext(&seg, arena, seg));