From f9724af3e0d7a413b596a72f7d2d247f8daa260d Mon Sep 17 00:00:00 2001
From: Richard Brooksby <rb@ravenbrook.com>
Date: Wed, 12 Jun 2013 15:33:49 +0100
Subject: [PATCH] Catch-up merge from custom/cet/main to master, to pick up
 arena extension callbacks.

Copied from Perforce
 Change: 182701
 ServerID: perforce.ravenbrook.com
---
 mps/code/arenavm.c  | 53 +++++++++++++++++++++++++++++++++++++++++++++
 mps/code/mpmtypes.h |  5 +++++
 mps/code/mps.h      |  3 +++
 3 files changed, 61 insertions(+)

diff --git a/mps/code/arenavm.c b/mps/code/arenavm.c
index f94632d3adf..616c16e5e8f 100644
--- a/mps/code/arenavm.c
+++ b/mps/code/arenavm.c
@@ -80,6 +80,8 @@ typedef struct VMArenaStruct {  /* VM arena structure */
   ZoneSet freeSet;               /* unassigned zones */
   Size extendBy;                /* desired arena increment */
   Size extendMin;               /* minimum arena increment */
+  ArenaVMExtendedCallback extended;
+  ArenaVMContractedCallback contracted;
   Sig sig;                      /* <design/sig/> */
 } VMArenaStruct;
 
@@ -455,11 +457,42 @@ static void VMArenaVarargs(ArgStruct args[MPS_ARGS_MAX], va_list varargs)
 }
 
 
+/* VMArenaTrivExtended -- trivial callback for VM arena extension */
+
+static void vmArenaTrivExtended(Arena arena, Addr base, Size size)
+{
+  AVERT(Arena, arena);
+  AVER(base != 0);
+  AVER(size > 0);
+  UNUSED(arena);
+  UNUSED(base);
+  UNUSED(size);
+}
+
+/* VMArenaTrivContracted -- trivial callback for VM arena contraction */
+
+static void vmArenaTrivContracted(Arena arena, Addr base, Size size)
+{
+  AVERT(Arena, arena);
+  AVER(base != 0);
+  AVER(size > 0);
+  UNUSED(arena);
+  UNUSED(base);
+  UNUSED(size);
+}
+
+
 /* VMArenaInit -- create and initialize the VM arena
  *
  * .arena.init: Once the arena has been allocated, we call ArenaInit
  * to do the generic part of init.
  */
+
+ARG_DEFINE_KEY(arena_extended, Fun);
+#define vmKeyArenaExtended (&_mps_key_arena_extended)
+ARG_DEFINE_KEY(arena_contracted, Fun);
+#define vmKeyArenaContracted (&_mps_key_arena_contracted)
+
 static Res VMArenaInit(Arena *arenaReturn, ArenaClass class, ArgList args)
 {
   Size userSize;        /* size requested by user */
@@ -544,6 +577,14 @@ static Res VMArenaInit(Arena *arenaReturn, ArenaClass class, ArgList args)
   vmArena->extendBy = userSize;
   vmArena->extendMin = 0;
 
+  vmArena->extended = vmArenaTrivExtended;
+  if (ArgPick(&arg, args, vmKeyArenaExtended))
+    vmArena->extended = (ArenaVMExtendedCallback)arg.val.fun;
+
+  vmArena->contracted = vmArenaTrivContracted;
+  if (ArgPick(&arg, args, vmKeyArenaContracted))
+    vmArena->contracted = (ArenaVMContractedCallback)arg.val.fun;
+
   /* have to have a valid arena before calling ChunkCreate */
   vmArena->sig = VMArenaSig;
   res = VMChunkCreate(&chunk, vmArena, userSize);
@@ -564,6 +605,9 @@ static Res VMArenaInit(Arena *arenaReturn, ArenaClass class, ArgList args)
     EVENT3(ArenaCreateVM, arena, userSize, chunkSize);
   else
     EVENT3(ArenaCreateVMNZ, arena, userSize, chunkSize);
+
+  vmArena->extended(arena, chunk->base, chunkSize);
+  
   *arenaReturn = arena;
   return ResOK;
 
@@ -1170,6 +1214,10 @@ static Res vmArenaExtend(VMArena vmArena, Size size)
 
 vmArenaExtend_Done:
   EVENT2(vmArenaExtendDone, chunkSize, VMArenaReserved(VMArena2Arena(vmArena)));
+  vmArena->extended(VMArena2Arena(vmArena),
+		    newChunk->base,
+		    AddrOffset(newChunk->base, newChunk->limit));
+
   return res;
 }
 
@@ -1678,7 +1726,12 @@ static void VMCompact(Arena arena, Trace trace)
     Chunk chunk = RING_ELT(Chunk, chunkRing, node);
     if(chunk != arena->primary
        && BTIsResRange(chunk->allocTable, 0, chunk->pages)) {
+      Addr base = chunk->base;
+      Size size = AddrOffset(chunk->base, chunk->limit);
+
       vmChunkDestroy(chunk);
+
+      vmArena->contracted(arena, base, size);
     }
   }
 
diff --git a/mps/code/mpmtypes.h b/mps/code/mpmtypes.h
index 360fab8d2e7..7ed5a89d9c8 100644
--- a/mps/code/mpmtypes.h
+++ b/mps/code/mpmtypes.h
@@ -129,6 +129,11 @@ typedef void (*ArenaChunkFinishMethod)(Chunk chunk);
 typedef void (*ArenaCompactMethod)(Arena arena, Trace trace);
 typedef Res (*ArenaDescribeMethod)(Arena arena, mps_lib_FILE *stream);
 
+/* These are not generally exposed and public, but are part of a commercial
+   extension to the MPS. */
+typedef void (*ArenaVMExtendedCallback)(Arena arena, Addr base, Size size);
+typedef void (*ArenaVMContractedCallback)(Arena arena, Addr base, Size size);
+
 
 /* TraceFixMethod */
 
diff --git a/mps/code/mps.h b/mps/code/mps.h
index 09ad3615d29..5bc46d4d1c9 100644
--- a/mps/code/mps.h
+++ b/mps/code/mps.h
@@ -111,6 +111,8 @@ typedef mps_addr_t (*mps_fmt_class_t)(mps_addr_t);
 
 /* Keyword argument lists */
 
+typedef void (*mps_fun_t)(void);
+
 typedef struct mps_arg_s {
   mps_key_t key;
   union {
@@ -124,6 +126,7 @@ typedef struct mps_arg_s {
     float f;
     double d;
     size_t size;
+    mps_fun_t fun;
     mps_addr_t addr;
     mps_fmt_t format;
     mps_chain_t chain;