Mps_arena_step() on masters.

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

8 files changed, 361 insertions, 50 deletions

diff --git a/mps/code/comm.gmk b/mps/code/comm.gmk
index bc561b09d6a..9085317bd21 100644
--- a/mps/code/comm.gmk
+++ b/mps/code/comm.gmk
@@ -281,7 +281,7 @@ endif
 all: mpmss sacss amcss amcsshe amsss amssshe segsmss awlut awluthe \
      mpsicv lockcov poolncv locv qs apss \
      finalcv arenacv bttest teletest \
-     abqtest cbstest btcv mv2test messtest \
+     abqtest cbstest btcv mv2test messtest steptest \
      eventcnv mps.a
 
 swall: mmsw.a epvmss replaysw epdss
@@ -292,7 +292,7 @@ swall: mmsw.a epvmss replaysw epdss
 #   mv2test cannot be run because MV2 is broken
 testrun: mpmss apss sacss amcss amcsshe amsss amssshe segsmss awlut awluthe \
          mpsicv lockcov poolncv locv qs finalcv arenacv \
-         abqtest cbstest btcv messtest
+         abqtest cbstest btcv messtest steptest
         $(^:%=date && $(PFM)/$(VARIETY)/% &&) true
 
 # Runs the automatic tests that are built with CONFIG_PROD_EPCORE
@@ -309,7 +309,7 @@ mpmss sacss amcss amcssth amcsshe amsss amssshe segsmss awlut awlutth \
   awluthe mpsicv lockcov poolncv locv qs apss \
   finalcv arenacv bttest teletest epvmss epdss \
   abqtest cbstest btcv mv2test \
-  messtest \
+  messtest steptest \
   eventcnv replay replaysw \
   mps.a mmsw.a mpsplan.a mmdw.a: phony
 ifdef VARIETY
@@ -445,6 +445,9 @@ $(PFM)/$(VARIETY)/mv2test: $(PFM)/$(VARIETY)/mv2test.o \
 $(PFM)/$(VARIETY)/messtest: $(PFM)/$(VARIETY)/messtest.o \
         $(MPMOBJ) $(PLINTHOBJ) $(TESTLIBOBJ)
 
+$(PFM)/$(VARIETY)/steptest: $(PFM)/$(VARIETY)/steptest.o \
+        $(FMTDYTSTOBJ) $(MPMOBJ) $(AMCOBJ) $(TESTLIBOBJ)
+
 $(PFM)/$(VARIETY)/eventcnv: $(PFM)/$(VARIETY)/eventcnv.o \
   $(PFM)/$(VARIETY)/eventpro.o $(PFM)/$(VARIETY)/table.o
 
diff --git a/mps/code/commpost.nmk b/mps/code/commpost.nmk
index 44bdad2d3d0..2cd7a14299e 100644
--- a/mps/code/commpost.nmk
+++ b/mps/code/commpost.nmk
@@ -17,7 +17,7 @@
 all: mpmss.exe amcss.exe amsss.exe amssshe.exe segsmss.exe awlut.exe awluthe.exe\
      mpsicv.exe lockutw3.exe lockcov.exe poolncv.exe locv.exe qs.exe apss.exe \
      finalcv.exe arenacv.exe bttest.exe teletest.exe protcv.exe \
-     abqtest.exe cbstest.exe btcv.exe mv2test.exe messtest.exe \
+     abqtest.exe cbstest.exe btcv.exe mv2test.exe messtest.exe steptest.exe \
      locbwcss.exe locusss.exe \
      eventcnv.exe
 
@@ -32,7 +32,7 @@ swall: mmsw.lib epvmss.exe replaysw.exe
 mpmss.exe amcss.exe amcsshe.exe amsss.exe amssshe.exe segsmss.exe awlut.exe awluthe.exe dwstress.exe \
      mpsicv.exe lockutw3.exe lockcov.exe poolncv.exe locv.exe qs.exe apss.exe \
      finalcv.exe arenacv.exe bttest.exe teletest.exe protcv.exe epvmss.exe \
-     abqtest.exe cbstest.exe btcv.exe mv2test.exe messtest.exe \
+     abqtest.exe cbstest.exe btcv.exe mv2test.exe messtest.exe steptest.exe \
      locbwcss.exe locusss.exe \
      replay.exe replaysw.exe eventcnv.exe \
      mmdw.lib mmsw.lib mps_conf.lib mpsplan.lib:
@@ -219,6 +219,10 @@ $(PFM)\$(VARIETY)\replaysw.exe: $(PFM)\$(VARIETY)\replaysw.obj \
 $(PFM)\$(VARIETY)\messtest.exe: $(PFM)\$(VARIETY)\messtest.obj \
         $(MPMOBJ) $(PLINTHOBJ) $(TESTLIBOBJ)
 
+$(PFM)\$(VARIETY)\steptest.exe: $(PFM)\$(VARIETY)\steptest.obj \
+        $(MPMOBJ) $(AMCOBJ) $(PLINTHOBJ) $(DWOBJ) $(DWTESTOBJ) \
+        $(TESTLIBOBJ)
+
 $(PFM)\$(VARIETY)\mmsw.lib: $(SWOBJ)
         $(ECHO) $@
         $(LIBMAN) $(LIBFLAGS) /OUT:$@ $**
diff --git a/mps/code/global.c b/mps/code/global.c
index 6cc309c1162..72b6ebb4183 100644
--- a/mps/code/global.c
+++ b/mps/code/global.c
@@ -274,7 +274,7 @@ Res GlobalsInit(Globals arenaGlobals)
 
   for (i=0; i < TraceLIMIT; i++) {
     /* design.mps.arena.trace.invalid */
-    arena->trace[i].sig = SigInvalid;  
+    arena->trace[i].sig = SigInvalid;
   }
   for(rank = 0; rank < RankLIMIT; ++rank)
     RingInit(&arena->greyRing[rank]);
@@ -556,16 +556,27 @@ void ArenaPoll(Globals globals)
 
   globals->insidePoll = TRUE;
 
-  TracePoll(globals);
+  (void)ArenaStep(globals, 0.0);
+
+  globals->insidePoll = FALSE;
+}
+#endif
+
+Bool ArenaStep(Globals globals, double interval)
+{
+  double size;
+  Bool b;
+
+  AVERT(Globals, globals);
+
+  b = TracePoll(globals);
 
   size = globals->fillMutatorSize;
   globals->pollThreshold = size + ArenaPollALLOCTIME;
   AVER(globals->pollThreshold > size); /* enough precision? */
 
-  globals->insidePoll = FALSE;
+  return b;
 }
-#endif
-
 
 /* ArenaFinalize -- registers an object for finalization
  *
@@ -678,7 +689,7 @@ Ref ArenaRead(Arena arena, Addr addr)
   Seg seg;
 
   AVERT(Arena, arena);
- 
+
   b = SegOfAddr(&seg, arena, addr);
   AVER(b == TRUE);
 
@@ -748,7 +759,7 @@ Res GlobalsDescribe(Globals arenaGlobals, mps_lib_FILE *stream)
                  NULL);
     if (res != ResOK) return res;
   }
- 
+
   res = WriteF(stream,
                "    [note: indices are raw, not rotated]\n"
                "    prehistory = $B\n", (WriteFB)arena->prehistory,
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index 990e51607d8..ecf16e2975c 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -408,7 +408,7 @@ extern void TraceDestroy(Trace trace);
 extern Res TraceAddWhite(Trace trace, Seg seg);
 extern Res TraceCondemnZones(Trace trace, ZoneSet condemnedSet);
 extern void TraceStart(Trace trace, double mortality, double finishingTime);
-extern void TracePoll(Globals globals);
+extern Bool TracePoll(Globals globals);
 
 extern void TraceSegAccess(Arena arena, Seg seg, AccessSet mode);
 extern Res TraceFix(ScanState ss, Ref *refIO);
@@ -523,6 +523,7 @@ extern void (ArenaPoll)(Globals globals);
 /* .nogc.why: ScriptWorks doesn't use MM-provided incremental GC, so */
 /* doesn't need to poll when allocating. */
 
+extern Bool (ArenaStep)(Globals globals, double interval);
 extern void ArenaClamp(Globals globals);
 extern void ArenaRelease(Globals globals);
 extern void ArenaPark(Globals globals);
diff --git a/mps/code/mps.h b/mps/code/mps.h
index 6adb0f6d84e..eb7812143c3 100644
--- a/mps/code/mps.h
+++ b/mps/code/mps.h
@@ -237,6 +237,7 @@ extern void mps_arena_clamp(mps_arena_t);
 extern void mps_arena_release(mps_arena_t);
 extern void mps_arena_park(mps_arena_t);
 extern mps_res_t mps_arena_collect(mps_arena_t);
+extern mps_bool_t mps_arena_step(mps_arena_t, double);
 extern void mps_space_clamp(mps_space_t);
 extern void mps_space_release(mps_space_t);
 extern void mps_space_park(mps_space_t);
diff --git a/mps/code/mpsi.c b/mps/code/mpsi.c
index 362dd0e0f9a..09bac2ef6aa 100644
--- a/mps/code/mpsi.c
+++ b/mps/code/mpsi.c
@@ -98,7 +98,7 @@ static Bool mpsi_check(void)
   /* The external idea of an address and the internal one */
   /* had better match. */
   CHECKL(CHECKTYPE(mps_addr_t, Addr));
- 
+
   /* The external idea of size and the internal one had */
   /* better match.  See design.mps.interface.c.cons.size */
   /* and design.mps.interface.c.pun.size. */
@@ -271,7 +271,7 @@ size_t mps_arena_commit_limit(mps_arena_t mps_arena)
 
   return size;
 }
- 
+
 mps_res_t mps_arena_commit_limit_set(mps_arena_t mps_arena, size_t limit)
 {
   Res res;
@@ -321,7 +321,7 @@ void mps_space_clamp(mps_space_t mps_space)
   mps_arena_clamp(mps_space);
 }
 
-  
+
 void mps_arena_release(mps_arena_t mps_arena)
 {
   Arena arena = (Arena)mps_arena;
@@ -335,7 +335,7 @@ void mps_space_release(mps_space_t mps_space)
 {
   mps_arena_release(mps_space);
 }
- 
+
 
 void mps_arena_park(mps_space_t mps_space)
 {
@@ -362,12 +362,22 @@ mps_res_t mps_arena_collect(mps_space_t mps_space)
   return res;
 }
 
+mps_bool_t mps_arena_step(mps_arena_t mps_arena, double time)
+{
+  Bool b;
+  Arena arena = (Arena)mps_arena;
+  ArenaEnter(arena);
+  b = ArenaStep(ArenaGlobals(arena), time);
+  ArenaLeave(arena);
+  return b;
+}
+
 /* for backward compatibility */
 mps_res_t mps_space_collect(mps_space_t mps_space)
 {
   return mps_arena_collect(mps_space);
 }
-   
+
 
 /* mps_arena_create -- create an arena object */
 
@@ -563,7 +573,7 @@ void mps_fmt_destroy(mps_fmt_t mps_fmt)
 {
   Format format = (Format)mps_fmt;
   Arena arena;
- 
+
   AVER(CHECKT(Format, format));
   arena = FormatArena(format);
 
@@ -603,7 +613,7 @@ mps_res_t mps_pool_create_v(mps_pool_t *mps_pool_o, mps_arena_t mps_arena,
   res = PoolCreateV(&pool, arena, class, args);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *mps_pool_o = (mps_pool_t)pool;
   return res;
@@ -631,7 +641,7 @@ mps_res_t mps_alloc(mps_addr_t *p_o, mps_pool_t mps_pool, size_t size, ...)
   Arena arena;
   Addr p;
   Res res;
- 
+
   AVER(CHECKT(Pool, pool));
   arena = PoolArena(pool);
 
@@ -673,7 +683,7 @@ void mps_free(mps_pool_t mps_pool, mps_addr_t p, size_t size)
 {
   Pool pool = (Pool)mps_pool;
   Arena arena;
- 
+
   AVER(CHECKT(Pool, pool));
   arena = PoolArena(pool);
 
@@ -700,7 +710,7 @@ mps_res_t mps_ap_create(mps_ap_t *mps_ap_o, mps_pool_t mps_pool, ...)
   BufferClass bufclass;
   Res res;
   va_list args;
- 
+
   AVER(mps_ap_o != NULL);
   AVER(CHECKT(Pool, pool));
   arena = PoolArena(pool);
@@ -733,7 +743,7 @@ mps_res_t mps_ap_create_v(mps_ap_t *mps_ap_o, mps_pool_t mps_pool,
   Buffer buf;
   BufferClass bufclass;
   Res res;
- 
+
   AVER(mps_ap_o != NULL);
   AVER(CHECKT(Pool, pool));
   arena = PoolArena(pool);
@@ -758,7 +768,7 @@ void mps_ap_destroy(mps_ap_t mps_ap)
   Buffer buf = BufferOfAP((AP)mps_ap);
   Arena arena;
 
-  AVER(mps_ap != NULL); 
+  AVER(mps_ap != NULL);
   AVER(CHECKT(Buffer, buf));
   arena = BufferArena(buf);
 
@@ -846,7 +856,7 @@ mps_bool_t (mps_commit)(mps_ap_t mps_ap, mps_addr_t p, size_t size)
 
 mps_res_t (mps_ap_frame_push)(mps_frame_t *frame_o, mps_ap_t mps_ap)
 {
-  AVER(frame_o != NULL); 
+  AVER(frame_o != NULL);
   AVER(mps_ap != NULL);
 
   /* Fail if between reserve & commit */
@@ -867,10 +877,10 @@ mps_res_t (mps_ap_frame_push)(mps_frame_t *frame_o, mps_ap_t mps_ap)
 
     AVER(CHECKT(Buffer, buf));
     arena = BufferArena(buf);
-   
+
     ArenaEnter(arena);
     AVERT(Buffer, buf);
-   
+
     res = BufferFramePush(&frame, buf);
 
     if (res == ResOK) {
@@ -910,10 +920,10 @@ mps_res_t (mps_ap_frame_pop)(mps_ap_t mps_ap, mps_frame_t frame)
 
     AVER(CHECKT(Buffer, buf));
     arena = BufferArena(buf);
-   
+
     ArenaEnter(arena);
     AVERT(Buffer, buf);
-   
+
     res = BufferFramePop(buf, (AllocFrame)frame);
 
     ArenaLeave(arena);
@@ -934,7 +944,7 @@ mps_res_t mps_ap_fill(mps_addr_t *p_o, mps_ap_t mps_ap, size_t size)
   Addr p;
   Res res;
 
-  AVER(mps_ap != NULL); 
+  AVER(mps_ap != NULL);
   AVER(CHECKT(Buffer, buf));
   arena = BufferArena(buf);
 
@@ -950,7 +960,7 @@ mps_res_t mps_ap_fill(mps_addr_t *p_o, mps_ap_t mps_ap, size_t size)
   res = BufferFill(&p, buf, size, FALSE);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *p_o = (mps_addr_t)p;
   return MPS_RES_OK;
@@ -965,7 +975,7 @@ mps_res_t mps_ap_fill_with_reservoir_permit(mps_addr_t *p_o, mps_ap_t mps_ap,
   Addr p;
   Res res;
 
-  AVER(mps_ap != NULL); 
+  AVER(mps_ap != NULL);
   AVER(CHECKT(Buffer, buf));
   arena = BufferArena(buf);
 
@@ -981,7 +991,7 @@ mps_res_t mps_ap_fill_with_reservoir_permit(mps_addr_t *p_o, mps_ap_t mps_ap,
   res = BufferFill(&p, buf, size, TRUE);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *p_o = (mps_addr_t)p;
   return MPS_RES_OK;
@@ -999,7 +1009,7 @@ mps_bool_t mps_ap_trip(mps_ap_t mps_ap, mps_addr_t p, size_t size)
   Arena arena;
   Bool b;
 
-  AVER(mps_ap != NULL); 
+  AVER(mps_ap != NULL);
   AVER(CHECKT(Buffer, buf));
   arena = BufferArena(buf);
 
@@ -1038,7 +1048,7 @@ mps_res_t mps_sac_create(mps_sac_t *mps_sac_o, mps_pool_t mps_pool,
   res = SACCreate(&sac, pool, (Count)classes_count, classes);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return (mps_res_t)res;
   *mps_sac_o = (mps_sac_t)ExternalSACOfSAC(sac);
   return (mps_res_t)res;
@@ -1175,7 +1185,7 @@ mps_res_t mps_root_create(mps_root_t *mps_root_o, mps_arena_t mps_arena,
                       (RootScanMethod)mps_root_scan, p, s);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *mps_root_o = (mps_root_t)root;
   return MPS_RES_OK;
@@ -1205,7 +1215,7 @@ mps_res_t mps_root_create_table(mps_root_t *mps_root_o, mps_arena_t mps_arena,
                         (Addr *)base, (Addr *)base + size);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *mps_root_o = (mps_root_t)root;
   return MPS_RES_OK;
@@ -1237,7 +1247,7 @@ mps_res_t mps_root_create_table_masked(mps_root_t *mps_root_o,
                               mask);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *mps_root_o = (mps_root_t)root;
   return MPS_RES_OK;
@@ -1254,7 +1264,7 @@ mps_res_t mps_root_create_fmt(mps_root_t *mps_root_o, mps_arena_t mps_arena,
   Root root;
   RootMode mode = (RootMode)mps_rm;
   Res res;
- 
+
   ArenaEnter(arena);
 
   AVER(mps_root_o != NULL);
@@ -1293,7 +1303,7 @@ mps_res_t mps_root_create_reg(mps_root_t *mps_root_o, mps_arena_t mps_arena,
                       reg_scan_p, mps_size);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *mps_root_o = (mps_root_t)root;
   return MPS_RES_OK;
@@ -1319,7 +1329,7 @@ void mps_root_destroy(mps_root_t mps_root)
 {
   Root root = (Root)mps_root;
   Arena arena;
- 
+
   arena = RootArena(root);
 
   ArenaEnter(arena);
@@ -1356,7 +1366,7 @@ mps_res_t mps_thread_reg(mps_thr_t *mps_thr_o, mps_arena_t mps_arena)
   res = ThreadRegister(&thread, arena);
 
   ArenaLeave(arena);
- 
+
   if (res != ResOK) return res;
   *mps_thr_o = (mps_thr_t)thread;
   return MPS_RES_OK;
@@ -1366,7 +1376,7 @@ void mps_thread_dereg(mps_thr_t mps_thr)
 {
   Thread thread = (Thread)mps_thr;
   Arena arena;
- 
+
   AVER(ThreadCheckSimple(thread));
   arena = ThreadArena(thread);
 
@@ -1601,7 +1611,7 @@ void mps_message_finalization_ref(mps_addr_t *mps_addr_return,
   Ref ref;
 
   AVER(mps_addr_return != NULL);
- 
+
   ArenaEnter(arena);
 
   AVERT(Arena, arena);
diff --git a/mps/code/steptest.c b/mps/code/steptest.c
new file mode 100644
index 00000000000..75d170476ad
--- /dev/null
+++ b/mps/code/steptest.c
@@ -0,0 +1,276 @@
+/* impl.c.steptest: TEST FOR ARENA CLAMPING AND STEPPING
+ *
+ * $Id$
+ * Copyright (C) 1998 Ravenbrook Limited.
+ *
+ * Based on impl.c.amcss.
+ */
+
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "testlib.h"
+#include "mpscamc.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#ifdef MPS_OS_W3
+#include "mpsw3.h"
+#endif
+#include "mps.h"
+#include <stdlib.h>
+#include <string.h>
+
+#define testArenaSIZE     ((size_t)(64l << 20))
+#define avLEN             3
+#define exactRootsCOUNT   200
+#define ambigRootsCOUNT   50
+#define objCOUNT          1000000
+#define genCOUNT          2
+
+/* testChain -- generation parameters for the test */
+
+static mps_gen_param_s testChain[genCOUNT] = {
+  { 150, 0.85 }, { 170, 0.45 } };
+
+
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL           ((mps_addr_t)0xDECEA5ED)
+
+static mps_pool_t pool;
+static mps_ap_t ap;
+static mps_addr_t exactRoots[exactRootsCOUNT];
+static mps_addr_t ambigRoots[ambigRootsCOUNT];
+
+
+#ifdef MPS_OS_W3
+
+static HANDLE currentProcess;
+
+static void prepare_clock(void)
+{
+  currentProcess = GetCurrentProcess();
+}
+
+static double my_clock(void)
+{
+    FILETIME ctime, etime, ktime, utime;
+    double dk, du;
+    GetProcessTimes(currentProcess, &ctime, &etime, &ktime, &utime);
+    dk = ktime.dwHighDateTime * 4096.0 * 1024.0 * 1024.0 + ktime.dwLowDateTime;
+    dk /= 10.0;
+    du = utime.dwHighDateTime * 4096.0 * 1024.0 * 1024.0 + utime.dwLowDateTime;
+    du /= 10.0;
+    return (du+dk);
+}
+
+#else
+/* on Posix systems, we can use getrusage. */
+
+#include <sys/types.h>
+#include <sys/time.h>
+#include <sys/resource.h>
+
+static void prepare_clock(void)
+{
+}
+
+static double my_clock(void)
+{
+    struct rusage ru;
+    getrusage(RUSAGE_SELF, &ru);
+    return ((ru.ru_utime.tv_sec +
+             ru.ru_stime.tv_sec) * 1000000.0 +
+            (ru.ru_utime.tv_usec) +
+            (ru.ru_stime.tv_usec));
+}
+#endif
+
+double alloc_time, step_time, no_step_time, max_step_time, max_no_step_time, max_alloc_time;
+
+long steps, no_steps;
+
+long alloc_bytes;
+long commit_failures;
+
+#define CLOCK_TESTS 100000
+
+static double clock_timing(void)
+{
+    long i;
+    double t1, t2;
+
+    t2 = 0.0;
+    for (i=0; i<CLOCK_TESTS; ++i) {
+        t1 = my_clock();
+        t2 += my_clock()-t1;
+    }
+    return t2/CLOCK_TESTS;
+}
+
+static mps_addr_t make(void)
+{
+  size_t length = rnd() % (2*avLEN);
+  size_t size = (length+2) * sizeof(mps_word_t);
+  mps_addr_t p;
+  mps_res_t res;
+
+  alloc_bytes += size;
+
+  for(;;) {
+    mps_bool_t commit_res;
+    double t1 = my_clock();
+    MPS_RESERVE_BLOCK(res, p, ap, size);
+    t1 = my_clock() - t1;
+    alloc_time += t1;
+    if (t1 > max_alloc_time)
+      max_alloc_time = t1;
+    if(res)
+      die(res, "MPS_RESERVE_BLOCK");
+    res = dylan_init(p, size, exactRoots, exactRootsCOUNT);
+    if(res)
+      die(res, "dylan_init");
+    t1 = my_clock();
+    commit_res = mps_commit(ap, p, size);
+    t1 = my_clock() - t1;
+    alloc_time += t1;
+    if (t1 > max_alloc_time)
+      max_alloc_time = t1;
+    if (commit_res)
+      break;
+    else
+      ++ commit_failures;
+  }
+
+  return p;
+}
+
+static void test_step(mps_arena_t arena)
+{
+  mps_bool_t res;
+  double t1 = my_clock();
+  res = mps_arena_step(arena, 0.1);
+  t1 = my_clock() - t1;
+  if (res) {
+    if (t1 > max_step_time)
+      max_step_time = t1;
+    step_time += t1;
+    ++ steps;
+  } else {
+    if (t1 > max_no_step_time)
+      max_no_step_time = t1;
+    no_step_time += t1;
+    ++ no_steps;
+  }
+}
+
+/* test -- the body of the test */
+
+static void *test(void *arg, size_t s)
+{
+  mps_arena_t arena;
+  mps_fmt_t format;
+  mps_chain_t chain;
+  mps_root_t exactRoot, ambigRoot;
+  unsigned long objs; size_t i;
+
+  arena = (mps_arena_t)arg;
+  (void)s; /* unused */
+
+  die(dylan_fmt(&format, arena), "fmt_create");
+  die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
+
+  die(mps_pool_create(&pool, arena, mps_class_amc(), format, chain),
+      "pool_create(amc)");
+
+  die(mps_ap_create(&ap, pool, MPS_RANK_EXACT), "BufferCreate");
+
+  for(i = 0; i < exactRootsCOUNT; ++i)
+    exactRoots[i] = objNULL;
+  for(i = 0; i < ambigRootsCOUNT; ++i)
+    ambigRoots[i] = (mps_addr_t)rnd();
+
+  die(mps_root_create_table_masked(&exactRoot, arena,
+                                   MPS_RANK_EXACT, (mps_rm_t)0,
+                                   &exactRoots[0], exactRootsCOUNT,
+                                   (mps_word_t)1),
+      "root_create_table(exact)");
+  die(mps_root_create_table(&ambigRoot, arena,
+                            MPS_RANK_AMBIG, (mps_rm_t)0,
+                            &ambigRoots[0], ambigRootsCOUNT),
+      "root_create_table(ambig)");
+
+  objs = 0;
+  steps = no_steps = 0;
+  alloc_bytes = 0;
+  commit_failures = 0;
+  alloc_time = step_time = no_step_time = 0.0;
+  max_alloc_time = max_step_time = max_no_step_time = 0.0;
+
+  while(objs < objCOUNT) {
+    size_t r;
+
+    r = (size_t)rnd();
+    if(r & 1) {
+      i = (r >> 1) % exactRootsCOUNT;
+      if(exactRoots[i] != objNULL)
+        cdie(dylan_check(exactRoots[i]), "dying root check");
+      exactRoots[i] = make();
+      if(exactRoots[(exactRootsCOUNT-1) - i] != objNULL)
+        dylan_write(exactRoots[(exactRootsCOUNT-1) - i],
+                    exactRoots, exactRootsCOUNT);
+    } else {
+      i = (r >> 1) % ambigRootsCOUNT;
+      ambigRoots[(ambigRootsCOUNT-1) - i] = make();
+      /* Create random interior pointers */
+      ambigRoots[i] = (mps_addr_t)((char *)(ambigRoots[i/2]) + 1);
+    }
+
+    if(objs % 1000 == 0) {
+        test_step(arena);
+    }
+
+    ++objs;
+  }
+
+  printf("%ld objects (%ld bytes) allocated\n", objs, alloc_bytes);
+  printf("commit failed %ld times\n", commit_failures);
+  printf("allocation took %.0f us, mean %.2f us, max %.0f us\n",
+         alloc_time, alloc_time / objs, max_alloc_time);
+  printf("%ld steps took %.0f us, mean %.2f us, max %.0f us\n",
+         steps, step_time, step_time / steps, max_step_time);
+  printf("%ld non-steps took %.0f us, mean %.2f us, max %.0f us\n",
+         no_steps, no_step_time, no_step_time / no_steps, max_no_step_time);
+
+  printf("clock timing %.2f us\n", clock_timing());
+
+  mps_ap_destroy(ap);
+  mps_root_destroy(exactRoot);
+  mps_root_destroy(ambigRoot);
+  mps_pool_destroy(pool);
+  mps_chain_destroy(chain);
+  mps_fmt_destroy(format);
+
+  return NULL;
+}
+
+int main(int argc, char **argv)
+{
+  mps_arena_t arena;
+  mps_thr_t thread;
+  void *r;
+
+  prepare_clock();
+
+  randomize(argc, argv);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "arena_create");
+  die(mps_arena_commit_limit_set(arena, testArenaSIZE), "set limit");
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  mps_tramp(&r, test, arena, 0);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  fflush(stdout); /* synchronize */
+  fprintf(stderr, "\nConclusion:  Failed to find any defects.\n");
+  return 0;
+}
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 5b118e87bb6..44acc32b0df 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -712,7 +712,7 @@ void TraceDestroy(Trace trace)
     /* Notify all the chains. */
     RING_FOR(chainNode, &trace->arena->chainRing, nextChainNode) {
       Chain chain = RING_ELT(Chain, chainRing, chainNode);
-     
+
       ChainEndGC(chain, trace);
     }
   } else {
@@ -1422,7 +1422,7 @@ void TraceStart(Trace trace, double mortality, double finishingTime)
           if (TraceSetIsMember(SegGrey(seg), trace))
             trace->foundation += size;
         }
-       
+
         if ((SegPool(seg)->class->attr & AttrGC)
             && !TraceSetIsMember(SegWhite(seg), trace))
           trace->notCondemned += size;
@@ -1509,11 +1509,12 @@ static void traceQuantum(Trace trace)
 
 /* TracePoll -- Check if there's any tracing work to be done */
 
-void TracePoll(Globals globals)
+Bool TracePoll(Globals globals)
 {
   Trace trace;
   Res res;
   Arena arena;
+  Bool done = FALSE;
 
   AVERT(Globals, globals);
   arena = GlobalsArena(globals);
@@ -1549,6 +1550,7 @@ void TracePoll(Globals globals)
         /* Run out of time, should really try a smaller collection. @@@@ */
         finishingTime = 0.0;
       TraceStart(trace, TraceTopGenMortality, finishingTime);
+      done = TRUE;
     } else { /* Find the nursery most over its capacity. */
       Ring node, nextNode;
       double firstTime = 0.0;
@@ -1577,6 +1579,7 @@ void TracePoll(Globals globals)
         trace->chain = firstChain;
         ChainStartGC(firstChain, trace);
         TraceStart(trace, mortality, trace->condemned * TraceWorkFactor);
+        done = TRUE;
       }
     } /* (dynamicDeferral > 0.0) */
   } /* (arena->busyTraces == TraceSetEMPTY) */
@@ -1588,11 +1591,13 @@ void TracePoll(Globals globals)
     traceQuantum(trace);
     if (trace->state == TraceFINISHED)
       TraceDestroy(trace);
+    done = TRUE;
   }
-  return;
+  return done;
 
 failCondemn:
   TraceDestroy(trace);
+  return FALSE;
 }
 
 
@@ -1611,7 +1616,7 @@ void ArenaRelease(Globals globals)
 {
   AVERT(Globals, globals);
   globals->clamped = FALSE;
-  TracePoll(globals);
+  (void)TracePoll(globals);
 }