Ensure that at most one collection of the world can be started in a call to arenapoll. this avoids a loop if the live set is large enough to provoke the "dynamic criterion".

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

mps/code/global.c

@@ -693,6 +693,7 @@ void (ArenaPoll)(Globals globals)
 {
   Arena arena;
   Clock start;
+  Bool worldCollected = FALSE;
   Bool moreWork, workWasDone = FALSE;
   Work tracedWork;
 
@@ -714,7 +715,8 @@ void (ArenaPoll)(Globals globals)
   EVENT3(ArenaPoll, arena, start, FALSE);
 
   do {
-    moreWork = TracePoll(&tracedWork, globals);
+    moreWork = TracePoll(&tracedWork, &worldCollected, globals,
+                         !worldCollected);
     if (moreWork) {
       workWasDone = TRUE;
     }
@@ -770,7 +772,8 @@ Bool ArenaStep(Globals globals, double interval, double multiplier)
         arena->lastWorldCollect = now;
       } else {
         /* Not worth collecting the world; consider starting a trace. */
-        if (!PolicyStartTrace(&trace, arena))
+        Bool worldCollected;
+        if (!PolicyStartTrace(&trace, &worldCollected, arena, FALSE))
           break;
       }
     }

mps/code/mpm.h

@@ -403,7 +403,8 @@ extern Bool TraceIsEmpty(Trace trace);
 extern Res TraceAddWhite(Trace trace, Seg seg);
 extern Res TraceCondemnZones(Trace trace, ZoneSet condemnedSet);
 extern Res TraceStart(Trace trace, double mortality, double finishingTime);
-extern Bool TracePoll(Work *workReturn, Globals globals);
+extern Bool TracePoll(Work *workReturn, Bool *collectWorldReturn,
+                      Globals globals, Bool collectWorldAllowed);
 
 extern Rank TraceRankForAccess(Arena arena, Seg seg);
 extern void TraceSegAccess(Arena arena, Seg seg, AccessSet mode);
@@ -657,7 +658,8 @@ extern Res PolicyAlloc(Tract *tractReturn, Arena arena, LocusPref pref,
                        Size size, Pool pool);
 extern Bool PolicyShouldCollectWorld(Arena arena, double availableTime,
                                      Clock now, Clock clocks_per_sec);
-extern Bool PolicyStartTrace(Trace *traceReturn, Arena arena);
+extern Bool PolicyStartTrace(Trace *traceReturn, Bool *collectWorldReturn,
+                             Arena arena, Bool collectWorldAllowed);
 extern Bool PolicyPoll(Arena arena);
 extern Bool PolicyPollAgain(Arena arena, Clock start, Bool moreWork, Work tracedWork);
 

mps/code/mpsicv.c

@@ -542,8 +542,13 @@ int main(int argc, char *argv[])
 
   testlib_init(argc, argv);
 
-  die(mps_arena_create(&arena, mps_arena_class_vm(), TEST_ARENA_SIZE),
-      "arena_create");
+  MPS_ARGS_BEGIN(args) {
+    /* Randomize pause time as a regression test for job004011. */
+    MPS_ARGS_ADD(args, MPS_KEY_PAUSE_TIME, rnd_pause_time());
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, TEST_ARENA_SIZE);
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args),
+        "arena_create\n");
+  } MPS_ARGS_END(args);
   die(mps_thread_reg(&thread, arena), "thread_reg");
 
   if (rnd() % 2) {

mps/code/policy.c

@@ -266,40 +266,53 @@ static Res policyCondemnChain(double *mortalityReturn, Chain chain, Trace trace)
 
 
 /* PolicyStartTrace -- consider starting a trace
+ *
+ * If collectWorldAllowed is TRUE, consider starting a collection of
+ * the world. Otherwise, consider only starting collections of individual
+ * chains or generations.
+ *
+ * If a collection of the world was started, set *collectWorldReturn
+ * to TRUE. Otherwise leave it unchanged.
  *
  * If a trace was started, update *traceReturn and return TRUE.
  * Otherwise, leave *traceReturn unchanged and return FALSE.
  */
 
-Bool PolicyStartTrace(Trace *traceReturn, Arena arena)
+Bool PolicyStartTrace(Trace *traceReturn, Bool *collectWorldReturn,
+                      Arena arena, Bool collectWorldAllowed)
 {
   Res res;
   Trace trace;
-  Size sFoundation, sCondemned, sSurvivors, sConsTrace;
-  double tTracePerScan; /* tTrace/cScan */
-  double dynamicDeferral;
 
-  /* Compute dynamic criterion.  See strategy.lisp-machine. */
-  AVER(arena->topGen.mortality >= 0.0);
-  AVER(arena->topGen.mortality <= 1.0);
-  sFoundation = (Size)0; /* condemning everything, only roots @@@@ */
-  /* @@@@ sCondemned should be scannable only */
-  sCondemned = ArenaCommitted(arena) - ArenaSpareCommitted(arena);
-  sSurvivors = (Size)(sCondemned * (1 - arena->topGen.mortality));
-  tTracePerScan = sFoundation + (sSurvivors * (1 + TraceCopyScanRATIO));
-  AVER(TraceWorkFactor >= 0);
-  AVER(sSurvivors + tTracePerScan * TraceWorkFactor <= (double)SizeMAX);
-  sConsTrace = (Size)(sSurvivors + tTracePerScan * TraceWorkFactor);
-  dynamicDeferral = (double)ArenaAvail(arena) - (double)sConsTrace;
+  if (collectWorldAllowed) {
+    Size sFoundation, sCondemned, sSurvivors, sConsTrace;
+    double tTracePerScan; /* tTrace/cScan */
+    double dynamicDeferral;
 
-  if (dynamicDeferral < 0.0) {
-    /* Start full collection. */
-    res = TraceStartCollectAll(&trace, arena, TraceStartWhyDYNAMICCRITERION);
-    if (res != ResOK)
-      goto failStart;
-    *traceReturn = trace;
-    return TRUE;
-  } else {
+    /* Compute dynamic criterion.  See strategy.lisp-machine. */
+    AVER(arena->topGen.mortality >= 0.0);
+    AVER(arena->topGen.mortality <= 1.0);
+    sFoundation = (Size)0; /* condemning everything, only roots @@@@ */
+    /* @@@@ sCondemned should be scannable only */
+    sCondemned = ArenaCommitted(arena) - ArenaSpareCommitted(arena);
+    sSurvivors = (Size)(sCondemned * (1 - arena->topGen.mortality));
+    tTracePerScan = sFoundation + (sSurvivors * (1 + TraceCopyScanRATIO));
+    AVER(TraceWorkFactor >= 0);
+    AVER(sSurvivors + tTracePerScan * TraceWorkFactor <= (double)SizeMAX);
+    sConsTrace = (Size)(sSurvivors + tTracePerScan * TraceWorkFactor);
+    dynamicDeferral = (double)ArenaAvail(arena) - (double)sConsTrace;
+
+    if (dynamicDeferral < 0.0) {
+      /* Start full collection. */
+      res = TraceStartCollectAll(&trace, arena, TraceStartWhyDYNAMICCRITERION);
+      if (res != ResOK)
+        goto failStart;
+      *collectWorldReturn = TRUE;
+      *traceReturn = trace;
+      return TRUE;
+    }
+  }
+  {
     /* Find the chain most over its capacity. */
     Ring node, nextNode;
     double firstTime = 0.0;

mps/code/testlib.c

@@ -12,7 +12,7 @@
 #include "mps.h"
 #include "misc.h" /* for NOOP */
 
-#include <math.h> /* fmod, log */
+#include <math.h> /* fmod, log, HUGE_VAL */
 #include <stdio.h> /* fflush, printf, stderr, sscanf, vfprintf */
 #include <stdlib.h> /* abort, exit, getenv */
 #include <time.h> /* time */
@@ -246,6 +246,15 @@ size_t rnd_align(size_t min, size_t max)
     return min;
 }
 
+double rnd_pause_time(void)
+{
+  double t = rnd_double();
+  if (t == 0.0)
+    return HUGE_VAL; /* Would prefer to use INFINITY but it's not in C89. */
+  else
+    return 1 / t - 1;
+}
+
 rnd_state_t rnd_seed(void)
 {
   /* Initialize seed based on seconds since epoch and on processor

mps/code/testlib.h

@@ -265,6 +265,11 @@ extern size_t rnd_grain(size_t arena_size);
 extern size_t rnd_align(size_t min, size_t max);
 
 
+/* rnd_pause_time -- random pause time */
+
+extern double rnd_pause_time(void);
+
+
 /* randomize -- randomize the generator, or initialize to replay
  *
  * randomize(argc, argv) randomizes the rnd generator (using time(3))

mps/code/trace.c

@@ -1831,12 +1831,17 @@ failCondemn:
 /* TracePoll -- Check if there's any tracing work to be done
  *
  * Consider starting a trace if none is running; advance the running
- * trace (if any) by one quantum. If there may be more work to do,
- * update *workReturn with a measure of the work done and return TRUE.
- * Otherwise return FALSE.
+ * trace (if any) by one quantum.
+ *
+ * The collectWorldReturn and collectWorldAllowed arguments are as for
+ * PolicyStartTrace.
+ *
+ * If there may be more work to do, update *workReturn with a measure
+ * of the work done and return TRUE. Otherwise return FALSE.
  */
 
-Bool TracePoll(Work *workReturn, Globals globals)
+Bool TracePoll(Work *workReturn, Bool *collectWorldReturn, Globals globals,
+               Bool collectWorldAllowed)
 {
   Trace trace;
   Arena arena;
@@ -1849,7 +1854,8 @@ Bool TracePoll(Work *workReturn, Globals globals)
     trace = ArenaTrace(arena, (TraceId)0);
   } else {
     /* No traces are running: consider starting one now. */
-    if (!PolicyStartTrace(&trace, arena))
+    if (!PolicyStartTrace(&trace, collectWorldReturn, arena,
+                          collectWorldAllowed))
       return FALSE;
   }
 

mps/code/zcoll.c

@@ -804,8 +804,13 @@ static void testscriptA(const char *script)
   printf("  Create arena, size = %lu.\n", arenasize);
 
   /* arena */
-  die(mps_arena_create(&arena, mps_arena_class_vm(), (size_t)arenasize),
-      "arena_create");
+  MPS_ARGS_BEGIN(args) {
+    /* Randomize pause time as a regression test for job004011. */
+    MPS_ARGS_ADD(args, MPS_KEY_PAUSE_TIME, rnd_pause_time());
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, arenasize);
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args),
+        "arena_create\n");
+  } MPS_ARGS_END(args);
 
   /* thr: used to stop/restart multiple threads */
   die(mps_thread_reg(&thr, arena), "thread");