Add mps_arena_start_collect(): starting an incremental world collection.

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

4 files changed, 79 insertions, 33 deletions

diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index d3845e00174..a3106830fed 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -475,6 +475,7 @@ extern Bool (ArenaStep)(Globals globals, double interval);
 extern void ArenaClamp(Globals globals);
 extern void ArenaRelease(Globals globals);
 extern void ArenaPark(Globals globals);
+extern Res ArenaStartCollect(Globals globals);
 extern Res ArenaCollect(Globals globals);
 extern Bool ArenaHasAddr(Arena arena, Addr addr);
 
diff --git a/mps/code/mps.h b/mps/code/mps.h
index ab49c39ed24..731ebe4925b 100644
--- a/mps/code/mps.h
+++ b/mps/code/mps.h
@@ -238,6 +238,7 @@ typedef struct mps_fmt_fixed_s {
 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_start_collect(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);
diff --git a/mps/code/mpsi.c b/mps/code/mpsi.c
index 9aa143057c8..58777f5cdd8 100644
--- a/mps/code/mpsi.c
+++ b/mps/code/mpsi.c
@@ -341,6 +341,16 @@ void mps_space_park(mps_space_t mps_space)
 }
 
 
+mps_res_t mps_arena_start_collect(mps_space_t mps_space)
+{
+  Res res;
+  Arena arena = (Arena)mps_space;
+  ArenaEnter(arena);
+  res = ArenaStartCollect(ArenaGlobals(arena));
+  ArenaLeave(arena);
+  return res;
+}
+
 mps_res_t mps_arena_collect(mps_space_t mps_space)
 {
   Res res;
diff --git a/mps/code/trace.c b/mps/code/trace.c
index 35463338f6c..32bca0d9b54 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -1507,6 +1507,37 @@ static void traceQuantum(Trace trace)
            && (trace->emergency || traceWorkClock(trace) < pollEnd));
 }
 
+/* traceStartCollectAll: start a trace which condemns everything in
+ * the arena. */
+
+static Res traceStartCollectAll(Trace *traceReturn, Arena arena)
+{
+  Trace trace;
+  Res res;
+  double finishingTime;
+
+  AVERT(Arena, arena);
+  AVER(arena->busyTraces == TraceSetEMPTY);
+
+  res = TraceCreate(&trace, arena);
+  AVER(res == ResOK); /* succeeds because no other trace is busy */
+  res = traceCondemnAll(trace);
+  if (res != ResOK) /* should try some other trace, really @@@@ */
+    goto failCondemn;
+  finishingTime = ArenaAvail(arena)
+                  - trace->condemned * (1.0 - TraceTopGenMortality);
+  if (finishingTime < 0)
+    /* Run out of time, should really try a smaller collection. @@@@ */
+    finishingTime = 0.0;
+  TraceStart(trace, TraceTopGenMortality, finishingTime);
+  *traceReturn = trace;
+  return ResOK;
+
+failCondemn:
+  TraceDestroy(trace);
+  return res;
+}
+
 
 /* TracePoll -- Check if there's any tracing work to be done */
 
@@ -1537,22 +1568,12 @@ Bool TracePoll(Globals globals)
     AVER(TraceWorkFactor >= 0);
     AVER(sSurvivors + tTracePerScan * TraceWorkFactor <= (double)SizeMAX);
     sConsTrace = (Size)(sSurvivors + tTracePerScan * TraceWorkFactor);
-    dynamicDeferral = (double)sConsTrace - (double)ArenaAvail(arena);
-
-    if (dynamicDeferral > 0.0) { /* start full GC */
-      double finishingTime;
-
-      res = TraceCreate(&trace, arena);
-      AVER(res == ResOK); /* succeeds because no other trace is busy */
-      res = traceCondemnAll(trace);
-      if (res != ResOK) /* should try some other trace, really @@@@ */
-        goto failCondemn;
-      finishingTime = ArenaAvail(arena)
-                      - trace->condemned * (1.0 - TraceTopGenMortality);
-      if (finishingTime < 0)
-        /* Run out of time, should really try a smaller collection. @@@@ */
-        finishingTime = 0.0;
-      TraceStart(trace, TraceTopGenMortality, finishingTime);
+    dynamicDeferral = (double)ArenaAvail(arena) - (double)sConsTrace;
+
+    if (dynamicDeferral < 0.0) { /* start full GC */
+      res = traceStartCollectAll(&trace, arena);
+      if (res != ResOK)
+        goto failStart;
       done = TRUE;
     } else { /* Find the nursery most over its capacity. */
       Ring node, nextNode;
@@ -1600,11 +1621,12 @@ Bool TracePoll(Globals globals)
 
 failCondemn:
   TraceDestroy(trace);
+failStart:
   return FALSE;
 }
 
 
-/* ArenaClamp -- clamp the arena (no new collections) */
+/* ArenaClamp -- clamp the arena (no optional collection increments) */
 
 void ArenaClamp(Globals globals)
 {
@@ -1613,7 +1635,8 @@ void ArenaClamp(Globals globals)
 }
 
 
-/* ArenaRelease -- release the arena (allow new collections) */
+/* ArenaRelease -- release the arena (allow optional collection
+ * increments) */
 
 void ArenaRelease(Globals globals)
 {
@@ -1623,7 +1646,7 @@ void ArenaRelease(Globals globals)
 }
 
 
-/* ArenaClamp -- finish all collections and clamp the arena */
+/* ArenaPark -- finish all current collections and clamp the arena */
 
 void ArenaPark(Globals globals)
 {
@@ -1646,34 +1669,45 @@ void ArenaPark(Globals globals)
   }
 }
 
+/* ArenaStartCollect -- start a collection of everything in the
+ * arena; leave unclamped. */
 
-/* ArenaCollect -- collect everything in arena */
-
-Res ArenaCollect(Globals globals)
+Res ArenaStartCollect(Globals globals)
 {
-  Trace trace;
+  Arena arena;
   Res res;
+  Trace trace;
 
   AVERT(Globals, globals);
+  arena = GlobalsArena(globals);
+
   ArenaPark(globals);
+  res = traceStartCollectAll(&trace, arena);
+  if (res != ResOK)
+    goto failStart;
+  ArenaRelease(globals);
+  return ResOK;
 
-  res = TraceCreate(&trace, GlobalsArena(globals));
-  AVER(res == ResOK); /* should be a trace available -- we're parked */
+failStart:
+  ArenaRelease(globals);
+  return res;
+}
 
-  res = traceCondemnAll(trace);
+/* ArenaCollect -- collect everything in arena; leave clamped */
+
+Res ArenaCollect(Globals globals)
+{
+  Res res;
+
+  AVERT(Globals, globals);
+  res = ArenaStartCollect(globals);
   if (res != ResOK)
-    goto failBegin;
+    return res;
 
-  TraceStart(trace, 0.0, 0.0);
   ArenaPark(globals);
   return ResOK;
-
-failBegin:
-  TraceDestroy(trace);
-  return res;
 }
 
-
 /* C. COPYRIGHT AND LICENSE
  *
  * Copyright (C) 2001-2002 Ravenbrook Limited <http://www.ravenbrook.com/>.