Fix problems identified by rb in review <https://info.ravenbrook.com/mail/2014/06/05/14-58-24/0/>.

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

mps/code/arena.c

@@ -638,6 +638,7 @@ typedef struct ArenaAllocPageClosureStruct {
   Pool pool;
   Addr base;
   Chunk avoid;
+  Res res;
 } ArenaAllocPageClosureStruct, *ArenaAllocPageClosure;
 
 static Bool arenaAllocPageInChunk(Tree tree, void *closureP, Size closureS)
@@ -656,18 +657,25 @@ static Bool arenaAllocPageInChunk(Tree tree, void *closureP, Size closureS)
   UNUSED(closureS);
 
   /* Already searched in arenaAllocPage. */
-  if (chunk == cl->avoid)
+  if (chunk == cl->avoid) {
+    cl->res = ResRESOURCE;
     return TRUE;
+  }
   
   if (!BTFindShortResRange(&basePageIndex, &limitPageIndex,
                            chunk->allocTable,
                            chunk->allocBase, chunk->pages, 1))
+  {
+    cl->res = ResRESOURCE;
     return TRUE;
+  }
   
   res = (*cl->arena->class->pagesMarkAllocated)(cl->arena, chunk,
                                                 basePageIndex, 1, cl->pool);
-  if (res != ResOK)
+  if (res != ResOK) {
+    cl->res = res;
     return TRUE;
+  }
   
   cl->base = PageIndexBase(chunk, basePageIndex);
   return FALSE;
@@ -685,6 +693,7 @@ static Res arenaAllocPage(Addr *baseReturn, Arena arena, Pool pool)
   closure.pool = pool;
   closure.base = NULL;
   closure.avoid = NULL;
+  closure.res = ResOK;
 
   /* Favour the primary chunk, because pages allocated this way aren't
      currently freed, and we don't want to prevent chunks being destroyed. */
@@ -697,7 +706,8 @@ static Res arenaAllocPage(Addr *baseReturn, Arena arena, Pool pool)
                     arenaAllocPageInChunk, &closure, 0))
     goto found;
 
-  return ResRESOURCE;
+  AVER(closure.res != ResOK);
+  return closure.res;
 
 found:
   AVER(closure.base != NULL);

mps/code/arenacl.c

@@ -173,15 +173,26 @@ static Res ClientChunkInit(Chunk chunk, BootBlock boot)
 
 /* clientChunkDestroy -- destroy a ClientChunk */
 
-static void clientChunkDestroy(Chunk chunk)
+static Bool clientChunkDestroy(Tree tree, void *closureP, Size closureS)
 {
+  Chunk chunk;
   ClientChunk clChunk;
 
+  AVERT(Tree, tree);
+  /* FIXME: AVER(closureP == UNUSED_POINTER); */
+  UNUSED(closureP);
+  /* FIXME: AVER(closureS == UNUSED_SIZE); */
+  UNUSED(closureS);
+  
+  chunk = ChunkOfTree(tree);
+  AVERT(Chunk, chunk);
   clChunk = Chunk2ClientChunk(chunk);
   AVERT(ClientChunk, clChunk);
 
   clChunk->sig = SigInvalid;
   ChunkFinish(chunk);
+
+  return TRUE;
 }
 
 
@@ -290,7 +301,6 @@ failChunkCreate:
 static void ClientArenaFinish(Arena arena)
 {
   ClientArena clientArena;
-  Tree *treeref, *nextref, tree, next;
 
   clientArena = Arena2ClientArena(arena);
   AVERT(ClientArena, clientArena);
@@ -298,9 +308,8 @@ static void ClientArenaFinish(Arena arena)
   /* Destroy all chunks, including the primary. See
    * <design/arena/#chunk.delete> */
   arena->primary = NULL;
-  TREE_TRAVERSE_AND_DELETE(treeref, nextref, tree, next, arena->chunkTree) {
-    clientChunkDestroy(ChunkOfTree(tree));
-  }
+  /* FIXME: use UNUSED_POINTER, UNUSED_SIZE instead of NULL, 0 */
+  TreeTraverseAndDelete(&arena->chunkTree, clientChunkDestroy, NULL, 0);
 
   clientArena->sig = SigInvalid;
 

mps/code/arenavm.c

@@ -401,11 +401,19 @@ failSaMapped:
 
 /* vmChunkDestroy -- destroy a VMChunk */
 
-static void vmChunkDestroy(Chunk chunk)
+static Bool vmChunkDestroy(Tree tree, void *closureP, Size closureS)
 {
   VM vm;
+  Chunk chunk;
   VMChunk vmChunk;
 
+  AVERT(Tree, tree);
+  /* FIXME: AVER(closureP == UNUSED_POINTER); */
+  UNUSED(closureP);
+  /* FIXME: AVER(closureS == UNUSED_SIZE); */
+  UNUSED(closureS);
+
+  chunk = ChunkOfTree(tree);
   AVERT(Chunk, chunk);
   vmChunk = Chunk2VMChunk(chunk);
   AVERT(VMChunk, vmChunk);
@@ -418,6 +426,8 @@ static void vmChunkDestroy(Chunk chunk)
   vm = vmChunk->vm;
   ChunkFinish(chunk);
   VMDestroy(vm);
+
+  return TRUE;
 }
 
 
@@ -589,7 +599,6 @@ static void VMArenaFinish(Arena arena)
 {
   VMArena vmArena;
   VM arenaVM;
-  Tree *treeref, *nextref, tree, next;
 
   vmArena = Arena2VMArena(arena);
   AVERT(VMArena, vmArena);
@@ -600,9 +609,8 @@ static void VMArenaFinish(Arena arena)
   /* Destroy all chunks, including the primary. See
    * <design/arena/#chunk.delete> */
   arena->primary = NULL;
-  TREE_TRAVERSE_AND_DELETE(treeref, nextref, tree, next, arena->chunkTree) {
-    vmChunkDestroy(ChunkOfTree(tree));
-  }
+  /* FIXME: use UNUSED_POINTER, UNUSED_SIZE instead of NULL, 0 */
+  TreeTraverseAndDelete(&arena->chunkTree, vmChunkDestroy, NULL, 0);
   
   /* Destroying the chunks should have purged and removed all spare pages. */
   RingFinish(&vmArena->spareRing);
@@ -1084,11 +1092,42 @@ static void VMFree(Addr base, Size size, Pool pool)
 }
 
 
+/* vmChunkCompact -- delete chunk if empty and not primary */
+
+static Bool vmChunkCompact(Tree tree, void *closureP, Size closureS)
+{
+  Chunk chunk;
+  Arena arena = closureP;
+  VMArena vmArena;
+
+  AVERT(Tree, tree);
+  AVERT(Arena, arena);
+  /* FIXME: AVER(closureS == UNUSED_SIZE); */
+  UNUSED(closureS);
+
+  vmArena = Arena2VMArena(arena);
+  AVERT(VMArena, vmArena);
+  chunk = ChunkOfTree(tree);
+  AVERT(Chunk, chunk);
+  if(chunk != arena->primary
+     && BTIsResRange(chunk->allocTable, 0, chunk->pages))
+  {
+    Addr base = chunk->base;
+    Size size = ChunkSize(chunk);
+    vmChunkDestroy(tree, closureP, closureS);
+    vmArena->contracted(arena, base, size);
+    return TRUE;
+  } else {
+    /* Keep this chunk. */
+    return FALSE;
+  }
+}
+
+
 static void VMCompact(Arena arena, Trace trace)
 {
   VMArena vmArena;
   Size vmem1;
-  Tree *treeref, *nextref, tree, next;
 
   vmArena = Arena2VMArena(arena);
   AVERT(VMArena, vmArena);
@@ -1099,21 +1138,8 @@ static void VMCompact(Arena arena, Trace trace)
   /* Destroy chunks that are completely free, but not the primary
    * chunk. See <design/arena/#chunk.delete>
    * TODO: add hysteresis here. See job003815. */
-  TREE_TRAVERSE_AND_DELETE(treeref, nextref, tree, next, arena->chunkTree) {
-    Chunk chunk = ChunkOfTree(tree);
-    AVERT(Chunk, chunk);
-    if(chunk != arena->primary
-       && BTIsResRange(chunk->allocTable, 0, chunk->pages))
-    {
-      Addr base = chunk->base;
-      Size size = ChunkSize(chunk);
-      vmChunkDestroy(chunk);
-      vmArena->contracted(arena, base, size);
-    } else {
-      /* Keep this chunk. */
-      treeref = nextref;
-    }
-  }
+  /* FIXME: use UNUSED_SIZE instead of 0 */
+  TreeTraverseAndDelete(&arena->chunkTree, vmChunkCompact, arena, 0);
 
   {
     Size vmem0 = trace->preTraceArenaReserved;

mps/code/tract.c

@@ -520,7 +520,6 @@ static Bool tractSearch(Tract *tractReturn, Arena arena, Addr addr)
     }
   }
   while (chunkAboveAddr(&chunk, arena, addr)) {
-    /* If the ring was kept in address order, this could be improved. */
     addr = chunk->base;
     /* Start from allocBase to skip the tables. */
     if (tractSearchInChunk(tractReturn, chunk, chunk->allocBase)) {

mps/code/tree.c

@@ -528,6 +528,41 @@ void TreeBalance(Tree *treeIO)
 }
 
 
+/* TreeTraverseAndDelete -- traverse a tree while deleting nodes 
+ *
+ * The visitor function must return TRUE to delete the current node,
+ * or FALSE to keep it.
+ *
+ * See <design/arena/#chunk.delete.tricky>.
+ */
+void TreeTraverseAndDelete(Tree *treeIO, TreeVisitor visitor,
+                           void *closureP, Size closureS)
+{
+  Tree *treeref = treeIO;
+
+  AVER(treeIO != NULL);
+  AVERT(Tree, *treeIO);
+  AVER(FUNCHECK(visitor));
+  /* closureP and closureS are arbitrary */
+
+  TreeToVine(treeIO);
+
+  while (*treeref != TreeEMPTY) {
+    Tree tree = *treeref;         /* Current node. */
+    Tree *nextref = &tree->right; /* Location of pointer to next node. */
+    Tree next = *nextref;         /* Next node. */
+    if ((*visitor)(tree, closureP, closureS)) {
+      /* Delete current node. */
+      *treeref = next;
+    } else {
+      /* Keep current node. */
+      treeref = nextref;
+    }
+  }
+  TreeBalance(treeIO);
+}
+
+
 /* C. COPYRIGHT AND LICENSE
  *
  * Copyright (C) 2014 Ravenbrook Limited <http://www.ravenbrook.com/>.

mps/code/tree.h

@@ -134,28 +134,8 @@ extern Tree TreeReverseRightSpine(Tree tree);
 extern Count TreeToVine(Tree *treeIO);
 extern void TreeBalance(Tree *treeIO);
 
-/* TREE_TRAVERSE_AND_DELETE -- traverse a tree while deleting nodes 
- *
- * root is an lvalue storing a pointer to the root of the tree. It is
- * evaluated twice.
- * treeref and nextref are variables of type Tree*.
- * tree and next are variables of type Tree.
- *
- * In the body of the loop, tree and next are the current and next
- * node respectively, and treeref and nextref are the locations where
- * pointers to these nodes are stored. Nodes are deleted from the tree
- * by default, or you can assign treeref = nextref in the body of the
- * loop to keep the current node.
- *
- * See <design/arena/#chunk.delete.tricky>.
- */
-#define TREE_TRAVERSE_AND_DELETE(treeref, nextref, tree, next, root)    \
-  for ((treeref = &(root), TreeToVine(treeref), next = TreeEMPTY);      \
-       (tree = *treeref) != TreeEMPTY                                   \
-         ? (nextref = &tree->right, next = *nextref, TRUE)              \
-         : (TreeBalance(&(root)), FALSE);                               \
-       *treeref = next)
-
+extern void TreeTraverseAndDelete(Tree *treeIO, TreeVisitor visitor,
+                                  void *closureP, Size closureS);
 
 #endif /* tree_h */