mps br/vmem: simple-chunk-return:

arenavm.c -- move chunk-return into new function "VMCompact".
 (also, in VMArenaFinish, null out arena->primary in VMArenaFinish, so it is not left dangling).

 arena.c, arenavm.c, mpm.h, mpmst.h, mpmtypes.h:
 arena->class->compact: ArenaCompact, ArenaTrivCompact, VMCompact

 trace.c -- traceReclaim calls ArenaCompact!

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

7 files changed, 77 insertions, 16 deletions

diff --git a/mps/code/arena.c b/mps/code/arena.c
index 21c1759d74a..ac3cec79f09 100644
--- a/mps/code/arena.c
+++ b/mps/code/arena.c
@@ -17,6 +17,11 @@ SRCID(arena, "$Id$");
 #define ArenaControlPool(arena) MV2Pool(&(arena)->controlPoolStruct)
 
 
+/* Forward declarations */
+
+static void ArenaTrivCompact(Arena arena, Trace trace);
+
+
 /* ArenaTrivDescribe -- produce trivial description of an arena */
 
 static Res ArenaTrivDescribe(Arena arena, mps_lib_FILE *stream)
@@ -63,6 +68,7 @@ DEFINE_CLASS(AbstractArenaClass, class)
   class->free = NULL;
   class->chunkInit = NULL;
   class->chunkFinish = NULL;
+  class->compact = ArenaTrivCompact;
   class->describe = ArenaTrivDescribe;
   class->sig = ArenaClassSig;
 }
@@ -701,6 +707,23 @@ Res ArenaNoExtend(Arena arena, Addr base, Size size)
 }
 
 
+/* ArenaCompact -- respond (or not) to trace reclaim */
+
+void ArenaCompact(Arena arena, Trace trace)
+{
+  AVERT(Arena, arena);
+  AVERT(Trace, trace);
+  (*arena->class->compact)(arena, trace);
+}
+
+static void ArenaTrivCompact(Arena arena, Trace trace)
+{
+  UNUSED(arena);
+  UNUSED(trace);
+  return;
+}
+
+
 /* Has Addr */
 
 Bool ArenaHasAddr(Arena arena, Addr addr)
diff --git a/mps/code/arenavm.c b/mps/code/arenavm.c
index dd329b58c5a..3fab5f4d547 100644
--- a/mps/code/arenavm.c
+++ b/mps/code/arenavm.c
@@ -91,6 +91,7 @@ typedef struct VMArenaStruct {  /* VM arena structure */
 static void sparePagesPurge(VMArena vmArena);
 static ArenaClass VMArenaClassGet(void);
 static ArenaClass VMNZArenaClassGet(void);
+static void VMCompact(Arena arena, Trace trace);
 
 
 /* VMChunkCheck -- check the consistency of a VM chunk */
@@ -540,7 +541,8 @@ static void VMArenaFinish(Arena arena)
   arenaVM = vmArena->vm;
 
   sparePagesPurge(vmArena);
-  /* destroy all chunks */
+  /* destroy all chunks, including the primary */
+  arena->primary = NULL;
   RING_FOR(node, &arena->chunkRing, next) {
     Chunk chunk = RING_ELT(Chunk, chunkRing, node);
     vmChunkDestroy(chunk);
@@ -1611,24 +1613,51 @@ static void VMFree(Addr base, Size size, Pool pool)
   if (arena->spareCommitted > arena->spareCommitLimit) {
     sparePagesPurge(vmArena);
   }
-  /* @@@@ Chunks are never freed. */
 
-  /* ... oh yes they are */
-  {
-    Ring node, next;
-    sparePagesPurge(vmArena);
-    /* Destroy any empty chunks (except the primary). */
-    RING_FOR(node, &arena->chunkRing, next) {
-      /*Chunk */chunk = RING_ELT(Chunk, chunkRing, node);
-      if(chunk != arena->primary
-         && BTIsResRange(chunk->allocTable, 0, chunk->pages))
-        vmChunkDestroy(chunk);
-    }
-  }
+  /* Chunks are only freed when ArenaCompact is called. */
 
   return;
 }
 
+static void VMCompact(Arena arena, Trace trace)
+{
+  VMArena vmArena;
+  Ring node, next;
+  DIAG_DECL( Size vmem1; )
+  DIAG_DECL( Size vmem2; )
+  DIAG_DECL( Size vmemD; )
+  DIAG_DECL( Count count; )
+
+  vmArena = Arena2VMArena(arena);
+  AVERT(VMArena, vmArena);
+  UNUSED(trace);  /* it's there for better diag; not used yet */
+
+  /* Destroy any empty chunks (except the primary). */
+  sparePagesPurge(vmArena);
+  DIAG(
+    vmem1 = VMArenaReserved(arena);
+    count = 0;
+  );
+  RING_FOR(node, &arena->chunkRing, next) {
+    Chunk chunk = RING_ELT(Chunk, chunkRing, node);
+    if(chunk != arena->primary
+       && BTIsResRange(chunk->allocTable, 0, chunk->pages)) {
+      vmChunkDestroy(chunk);
+      DIAG( count += 1; );
+    }
+  }
+  DIAG(
+    vmem2 = VMArenaReserved(arena);
+    vmemD = vmem1 - vmem2;
+    
+    if(vmemD != 0) {
+      DIAG_SINGLEF(( "VMCompact",
+        "vmem was $W, released $W, now $W", vmem1, vmemD, vmem2,
+        NULL));
+    }
+  );
+  
+}
 
 mps_res_t mps_arena_vm_growth(mps_arena_t mps_arena,
                               size_t mps_desired, size_t mps_minimum)
@@ -1675,6 +1704,7 @@ DEFINE_ARENA_CLASS(VMArenaClass, this)
   this->free = VMFree;
   this->chunkInit = VMChunkInit;
   this->chunkFinish = VMChunkFinish;
+  this->compact = VMCompact;
   this->describe = VMArenaDescribe;
 }
 
diff --git a/mps/code/mpm.h b/mps/code/mpm.h
index b4189afadcd..371319aeee6 100644
--- a/mps/code/mpm.h
+++ b/mps/code/mpm.h
@@ -570,6 +570,8 @@ extern Size ArenaAvail(Arena arena);
 
 extern Res ArenaExtend(Arena, Addr base, Size size);
 
+extern void ArenaCompact(Arena arena, Trace trace);
+
 extern Res ArenaFinalize(Arena arena, Ref obj);
 extern Res ArenaDefinalize(Arena arena, Ref obj);
 
diff --git a/mps/code/mpmst.h b/mps/code/mpmst.h
index 23409087808..c5a4fe0e3f3 100644
--- a/mps/code/mpmst.h
+++ b/mps/code/mpmst.h
@@ -567,6 +567,7 @@ typedef struct ArenaClassStruct {
   ArenaFreeMethod free;
   ArenaChunkInitMethod chunkInit;
   ArenaChunkFinishMethod chunkFinish;
+  ArenaCompactMethod compact;
   ArenaDescribeMethod describe;
   Sig sig;
 } ArenaClassStruct;
diff --git a/mps/code/mpmtypes.h b/mps/code/mpmtypes.h
index fd27f8c2a80..056ac0d2ec9 100644
--- a/mps/code/mpmtypes.h
+++ b/mps/code/mpmtypes.h
@@ -118,6 +118,7 @@ typedef Res (*ArenaAllocMethod)(Addr *baseReturn, Tract *baseTractReturn,
 typedef void (*ArenaFreeMethod)(Addr base, Size size, Pool pool);
 typedef Res (*ArenaChunkInitMethod)(Chunk chunk, BootBlock boot);
 typedef void (*ArenaChunkFinishMethod)(Chunk chunk);
+typedef void (*ArenaCompactMethod)(Arena arena, Trace trace);
 typedef Res (*ArenaDescribeMethod)(Arena arena, mps_lib_FILE *stream);
 
 
diff --git a/mps/code/plan.txt b/mps/code/plan.txt
index faeb16a6791..23bf274ecac 100644
--- a/mps/code/plan.txt
+++ b/mps/code/plan.txt
@@ -15,9 +15,11 @@ The primary chunk is used specially:
 
 1. Arenacl requires a chunk to store the ArenaStruct in.  (Whereas arenavm gets storage by simply mapping a new page).  Therefore destroying the primary chunk would (in general) destroy the arena.
 
-2. PageSize is known by chunks, not the arena.  When arena needs to know page size, it asks the primary chunk.
+2. there's a field arena->primary that stores a pointer to the primary chunk.  If the primary chunk ever goes away (eg. at ArenaFinish), this pointer must be nulled out so it is not left dangling.
 
-3. Various *Check functions only bother to check the primary chunk, and ignore other chunks.
+3. PageSize is known by chunks, not the arena.  When arena needs to know page size, it asks the primary chunk.
+
+4. Various *Check functions only bother to check the primary chunk, and ignore other chunks.
 
 
 
diff --git a/mps/code/trace.c b/mps/code/trace.c
index b4b17c11b49..5cffa818009 100644
--- a/mps/code/trace.c
+++ b/mps/code/trace.c
@@ -813,6 +813,8 @@ static void traceReclaim(Trace trace)
     PoolTraceEnd(pool, trace);
   }
 
+  ArenaCompact(arena, trace);  /* let arenavm drop chunks */
+
   TracePostMessage(trace);  /* trace end */
   /* Immediately pre-allocate messages for next time; failure is okay */
   (void)TraceIdMessagesCreate(arena, trace->ti);