1 files changed, 649 insertions, 0 deletions

diff --git a/mps/code/arena.c b/mps/code/arena.c
new file mode 100644
index 00000000000..c0bb7888524
--- /dev/null
+++ b/mps/code/arena.c
@@ -0,0 +1,649 @@
+/* impl.c.arena: ARENA ALLOCATION FEATURES
+ *
+ * $HopeName: MMsrc!arena.c(trunk.79) $
+ * Copyright (C) 2001 Harlequin Limited.  All rights reserved.
+ * 
+ * .sources: design.mps.arena is the main design document.  */
+
+#include "tract.h"
+#include "poolmv.h"
+#include "mpm.h"
+
+SRCID(arena, "$HopeName: MMsrc!arena.c(trunk.79) $");
+
+
+/* ArenaControlPool -- get the control pool */
+
+#define ArenaControlPool(arena) MVPool(&(arena)->controlPoolStruct)
+
+
+/* ArenaTrivDescribe -- produce trivial description of an arena */
+
+static Res ArenaTrivDescribe(Arena arena, mps_lib_FILE *stream)
+{
+  if (!CHECKT(Arena, arena)) return ResFAIL;
+  if (stream == NULL) return ResFAIL;
+
+  return WriteF(stream, 
+    "  No class-specific description available.\n", NULL);
+}
+
+
+/* AbstractArenaClass  -- The abstact arena class definition
+ *
+ * .null: Most abstract class methods are set to NULL.  See
+ * design.mps.arena.class.abstract.null.  */
+
+typedef ArenaClassStruct AbstractArenaClassStruct;
+
+DEFINE_CLASS(AbstractArenaClass, class)
+{
+  INHERIT_CLASS(&class->protocol, ProtocolClass);
+  class->name = "ABSARENA";
+  class->size = 0;
+  class->offset = 0;
+  class->init = NULL;
+  class->finish = NULL;
+  class->reserved = NULL;
+  class->spareCommitExceeded = ArenaNoSpareCommitExceeded;
+  class->extend = ArenaNoExtend;
+  class->alloc = NULL;
+  class->free = NULL;
+  class->chunkInit = NULL;
+  class->chunkFinish = NULL;
+  class->describe = ArenaTrivDescribe;
+  class->sig = ArenaClassSig;
+}
+
+
+/* ArenaClassCheck -- check the consistency of an arena class */
+
+Bool ArenaClassCheck(ArenaClass class)
+{
+  CHECKL(ProtocolClassCheck(&class->protocol));
+  CHECKL(class->name != NULL); /* Should be <=6 char C identifier */
+  CHECKL(class->size >= sizeof(ArenaStruct));
+  /* Offset of generic Pool within class-specific instance cannot be */
+  /* greater than the size of the class-specific portion of the */
+  /* instance. */
+  CHECKL(class->offset <= (size_t)(class->size - sizeof(ArenaStruct)));
+  CHECKL(FUNCHECK(class->init));
+  CHECKL(FUNCHECK(class->finish));
+  CHECKL(FUNCHECK(class->reserved));
+  CHECKL(FUNCHECK(class->spareCommitExceeded));
+  CHECKL(FUNCHECK(class->extend));
+  CHECKL(FUNCHECK(class->alloc));
+  CHECKL(FUNCHECK(class->free));
+  CHECKL(FUNCHECK(class->chunkInit));
+  CHECKL(FUNCHECK(class->chunkFinish));
+  CHECKL(FUNCHECK(class->describe));
+  CHECKS(ArenaClass, class);
+  return TRUE;
+}
+
+
+/* ArenaCheck -- check the arena */
+
+Bool ArenaCheck(Arena arena)
+{
+  CHECKS(Arena, arena);
+  CHECKD(Globals, ArenaGlobals(arena));
+  CHECKD(ArenaClass, arena->class);
+
+  CHECKL(BoolCheck(arena->poolReady));
+  if (arena->poolReady) { /* design.mps.arena.pool.ready */
+    CHECKD(MV, &arena->controlPoolStruct);
+    CHECKD(Reservoir, &arena->reservoirStruct);
+  }
+  /* Can't check that limit>=size because we may call ArenaCheck */
+  /* while the size is being adjusted. */
+
+  CHECKL(arena->committed <= arena->commitLimit);
+  CHECKL(arena->spareCommitted <= arena->committed);
+  CHECKL(arena->spareCommitted <= arena->spareCommitLimit);
+
+  CHECKL(ShiftCheck(arena->zoneShift));
+  CHECKL(AlignCheck(arena->alignment));
+  /* Tract allocation must be platform-aligned. */
+  CHECKL(arena->alignment >= MPS_PF_ALIGN);
+  /* Stripes can't be smaller than pages. */
+  CHECKL(((Size)1 << arena->zoneShift) >= arena->alignment);
+
+  if (arena->lastTract == NULL) {
+    CHECKL(arena->lastTractBase == (Addr)0);
+  } else {
+    CHECKL(TractBase(arena->lastTract) == arena->lastTractBase);
+  }
+
+  if (arena->primary != NULL) {
+    CHECKD(Chunk, arena->primary);
+  }
+  CHECKL(RingCheck(&arena->chunkRing));
+  /* nothing to check for chunkSerial */
+  CHECKD(ChunkCacheEntry, &arena->chunkCache);
+
+  CHECKL(LocusCheck(arena));
+
+  return TRUE;
+}
+
+
+/* ArenaInit -- initialize the generic part of the arena
+ *
+ * .init.caller: Unlike PoolInit, this is called by the class init
+ * methods, not the generic Create.  This is because the class is
+ * responsible for allocating the descriptor.  */
+
+Res ArenaInit(Arena arena, ArenaClass class)
+{
+  Res res;
+
+  /* We do not check the arena argument, because it's _supposed_ to */
+  /* point to an uninitialized block of memory. */
+  AVERT(ArenaClass, class);
+
+  arena->class = class;
+
+  arena->committed = (Size)0;
+  /* commitLimit may be overridden by init (but probably not */
+  /* as there's not much point) */
+  arena->commitLimit = (Size)-1;
+  arena->spareCommitted = (Size)0;
+  arena->spareCommitLimit = ARENA_INIT_SPARE_COMMIT_LIMIT;
+  /* alignment is usually overridden by init */
+  arena->alignment = 1 << ARENA_ZONESHIFT;
+  /* zoneShift is usually overridden by init */
+  arena->zoneShift = ARENA_ZONESHIFT;
+  arena->poolReady = FALSE;     /* design.mps.arena.pool.ready */
+  arena->lastTract = NULL;
+  arena->lastTractBase = NULL;
+
+  arena->primary = NULL;
+  RingInit(&arena->chunkRing);
+  arena->chunkSerial = (Serial)0;
+  ChunkCacheEntryInit(&arena->chunkCache);
+
+  LocusInit(arena);
+
+  res = GlobalsInit(ArenaGlobals(arena));
+  if (res != ResOK)
+    goto failGlobalsInit;
+
+  arena->sig = ArenaSig;
+
+  /* initialize the reservoir, design.mps.reservoir */
+  res = ReservoirInit(&arena->reservoirStruct, arena);
+  if (res != ResOK) 
+    goto failReservoirInit;
+
+  AVERT(Arena, arena);
+  return ResOK;
+
+failReservoirInit:
+  GlobalsFinish(ArenaGlobals(arena));
+failGlobalsInit:
+  return res;
+}
+
+
+/* ArenaCreateV -- create the arena and call initializers */
+
+Res ArenaCreateV(Arena *arenaReturn, ArenaClass class, va_list args)
+{
+  Arena arena;
+  Res res;
+
+  AVER(arenaReturn != NULL);
+  AVERT(ArenaClass, class);
+
+  /* Do initialization.  This will call ArenaInit (see .init.caller). */
+  res = (*class->init)(&arena, class, args);
+  if (res != ResOK)
+    goto failInit;
+
+  arena->alignment = ChunkPageSize(arena->primary);
+  if (arena->alignment > ((Size)1 << arena->zoneShift)) {
+    res = ResMEMORY; /* size was too small */
+    goto failStripeSize;
+  }
+
+  /* load cache */
+  ChunkEncache(arena, arena->primary);
+
+  res = ControlInit(arena);
+  if (res != ResOK) 
+    goto failControlInit;
+
+  res = GlobalsCompleteCreate(ArenaGlobals(arena));
+  if (res != ResOK) 
+    goto failGlobalsCompleteCreate;
+
+  AVERT(Arena, arena);
+  *arenaReturn = arena;
+  return ResOK;
+
+failGlobalsCompleteCreate:
+  ControlFinish(arena);
+failControlInit:
+failStripeSize:
+  (*class->finish)(arena);
+failInit:
+  return res;
+}
+
+
+/* ArenaFinish -- finish the generic part of the arena
+ *
+ * .finish.caller: Unlike PoolFinish, this is called by the class finish
+ * methods, not the generic Destroy.  This is because the class is
+ * responsible for deallocating the descriptor.  */
+
+void ArenaFinish(Arena arena)
+{
+  ReservoirFinish(ArenaReservoir(arena));
+  arena->sig = SigInvalid;
+  GlobalsFinish(ArenaGlobals(arena));
+  LocusFinish(arena);
+  RingFinish(&arena->chunkRing);
+}
+
+
+/* ArenaDestroy -- destroy the arena */
+
+void ArenaDestroy(Arena arena)
+{
+  AVERT(Arena, arena);
+
+  GlobalsPrepareToDestroy(ArenaGlobals(arena));
+
+  /* Empty the reservoir - see impl.c.reserv.reservoir.finish */
+  ReservoirSetLimit(ArenaReservoir(arena), 0);
+
+  arena->poolReady = FALSE;
+  ControlFinish(arena);
+
+  /* Call class-specific finishing.  This will call ArenaFinish. */
+  (*arena->class->finish)(arena);
+
+  EventFinish();
+}
+
+
+/* ControlInit -- initialize the control pool */
+
+Res ControlInit(Arena arena)
+{
+  Res res;
+
+  AVERT(Arena, arena);
+  res = PoolInit(&arena->controlPoolStruct.poolStruct, 
+                 arena, PoolClassMV(),
+                 ARENA_CONTROL_EXTENDBY, ARENA_CONTROL_AVGSIZE,
+                 ARENA_CONTROL_MAXSIZE);
+  if (res != ResOK) 
+    return res;
+  arena->poolReady = TRUE;      /* design.mps.arena.pool.ready */
+  return ResOK;
+}
+
+
+/* ControlFinish -- finish the control pool */
+
+void ControlFinish(Arena arena)
+{
+  AVERT(Arena, arena);
+  arena->poolReady = FALSE;
+  PoolFinish(&arena->controlPoolStruct.poolStruct);
+}
+
+
+/* ArenaDescribe -- describe the arena */
+
+Res ArenaDescribe(Arena arena, mps_lib_FILE *stream)
+{
+  Res res;
+
+  if (!CHECKT(Arena, arena)) return ResFAIL;
+  if (stream == NULL) return ResFAIL;
+
+  res = WriteF(stream, "Arena $P {\n", (WriteFP)arena,
+               "  class $P (\"$S\")\n", 
+               (WriteFP)arena->class, arena->class->name,
+               NULL);
+  if (res != ResOK) return res;
+
+  if (arena->poolReady) {
+    res = WriteF(stream,
+                 "  controlPool $P\n", (WriteFP)&arena->controlPoolStruct,
+                 NULL);
+    if (res != ResOK) return res;
+  }
+
+  res = WriteF(stream,
+               "  commitLimit $W\n", (WriteFW)arena->commitLimit,
+               "  spareCommitted $W\n", (WriteFW)arena->spareCommitted,
+               "  spareCommitLimit $W\n", (WriteFW)arena->spareCommitLimit,
+               "  zoneShift $U\n", (WriteFU)arena->zoneShift,
+               "  alignment $W\n", (WriteFW)arena->alignment,
+               NULL);
+  if (res != ResOK) return res;
+
+  res = (*arena->class->describe)(arena, stream);
+  if (res != ResOK) return res;
+
+  res = GlobalsDescribe(ArenaGlobals(arena), stream);
+  if (res != ResOK) return res;
+
+  res = WriteF(stream,
+               "} Arena $P ($U)\n", (WriteFP)arena, 
+               (WriteFU)arena->serial,
+               NULL);
+  return res;
+}
+
+
+/* ArenaDescribeTracts -- describe all the tracts in the arena */
+
+Res ArenaDescribeTracts(Arena arena, mps_lib_FILE *stream)
+{
+  Res res;
+  Tract tract;
+  Bool b;
+  Addr oldLimit, base, limit;
+  Size size;
+
+  if (!CHECKT(Arena, arena)) return ResFAIL;
+  if (stream == NULL) return ResFAIL;
+
+  b = TractFirst(&tract, arena); 
+  oldLimit = TractBase(tract);
+  while (b) {
+    base = TractBase(tract);
+    limit = TractLimit(tract);
+    size = ArenaAlign(arena);
+
+    if (TractBase(tract) > oldLimit) {
+      res = WriteF(stream,
+                   "[$P, $P) $W $U   ---\n",
+                   (WriteFP)oldLimit, (WriteFP)base,
+                   (WriteFW)AddrOffset(oldLimit, base),
+                   (WriteFU)AddrOffset(oldLimit, base),
+                   NULL);
+      if (res != ResOK) return res;
+    }
+
+    res = WriteF(stream,
+                 "[$P, $P) $W $U   $P ($S)\n",
+                 (WriteFP)base, (WriteFP)limit,
+                 (WriteFW)size, (WriteFW)size,
+                 (WriteFP)TractPool(tract),
+                 (WriteFS)(TractPool(tract)->class->name),
+                 NULL);
+    if (res != ResOK) return res;
+    b = TractNext(&tract, arena, TractBase(tract));
+    oldLimit = limit;
+  }
+  return ResOK;
+}
+
+
+/* ControlAlloc -- allocate a small block directly from the control pool
+ *
+ * .arena.control-pool: Actually the block will be allocated from the
+ * control pool, which is an MV pool embedded in the arena itself.
+ *
+ * .controlalloc.addr: In implementations where Addr is not compatible
+ * with void* (design.mps.type.addr.use), ControlAlloc must take care of
+ * allocating so that the block can be addressed with a void*.  */
+
+Res ControlAlloc(void **baseReturn, Arena arena, size_t size, 
+                 Bool withReservoirPermit)
+{
+  Addr base;
+  Res res;
+
+  AVERT(Arena, arena);
+  AVER(baseReturn != NULL);
+  AVER(size > 0);
+  AVER(BoolCheck(withReservoirPermit));
+  AVER(arena->poolReady);
+
+  res = PoolAlloc(&base, ArenaControlPool(arena), (Size)size,
+                  withReservoirPermit);
+  if (res != ResOK) 
+    return res;
+
+  *baseReturn = (void *)base; /* see .controlalloc.addr */
+  return ResOK;
+}
+
+
+/* ControlFree -- free a block allocated using ControlAlloc */
+
+void ControlFree(Arena arena, void* base, size_t size)
+{
+  AVERT(Arena, arena);
+  AVER(base != NULL);
+  AVER(size > 0);
+  AVER(arena->poolReady);
+
+  PoolFree(ArenaControlPool(arena), (Addr)base, (Size)size);
+}
+
+
+/* ArenaAlloc -- allocate some tracts from the arena */
+
+Res ArenaAlloc(Addr *baseReturn, SegPref pref, Size size, Pool pool,
+               Bool withReservoirPermit)
+{
+  Res res;
+  Arena arena;
+  Addr base;
+  Tract baseTract;
+  Reservoir reservoir;
+
+  AVER(baseReturn != NULL);
+  AVERT(SegPref, pref);
+  AVER(size > (Size)0);
+  AVERT(Pool, pool);
+  AVER(BoolCheck(withReservoirPermit));
+
+  arena = PoolArena(pool);
+  AVERT(Arena, arena);
+  AVER(SizeIsAligned(size, arena->alignment));
+  reservoir = ArenaReservoir(arena);
+  AVERT(Reservoir, reservoir);
+
+  res = ReservoirEnsureFull(reservoir);
+  if (res != ResOK) {
+    AVER(ResIsAllocFailure(res));
+    if (!withReservoirPermit)
+      return res;
+  }
+
+  res = (*arena->class->alloc)(&base, &baseTract, pref, size, pool);
+  if (res == ResOK) {
+    goto goodAlloc;
+  } else if (withReservoirPermit) {
+    AVER(ResIsAllocFailure(res));
+    res = ReservoirWithdraw(&base, &baseTract, reservoir, size, pool);
+    if (res == ResOK)
+      goto goodAlloc;
+  }
+  EVENT_PWP(ArenaAllocFail, arena, size, pool);
+  return res;
+
+goodAlloc:
+  /* cache the tract - design.mps.arena.tract.cache */
+  arena->lastTract = baseTract;
+  arena->lastTractBase = base;
+
+  EVENT_PPAWP(ArenaAlloc, arena, baseTract, base, size, pool);
+  *baseReturn = base;
+  return ResOK;
+}
+
+
+/* ArenaFree -- free some tracts to the arena */
+
+void ArenaFree(Addr base, Size size, Pool pool)
+{
+  Arena arena;
+  Addr limit;
+  Reservoir reservoir;
+  Res res;
+
+  AVERT(Pool, pool);
+  AVER(base != NULL);
+  AVER(size > (Size)0);
+  arena = PoolArena(pool);
+  AVERT(Arena, arena);
+  reservoir = ArenaReservoir(arena);
+  AVERT(Reservoir, reservoir);
+  AVER(AddrIsAligned(base, arena->alignment));
+  AVER(SizeIsAligned(size, arena->alignment));
+
+  /* uncache the tract if in range - design.mps.arena.tract.uncache */
+  limit = AddrAdd(base, size);
+  if ((arena->lastTractBase >= base) && (arena->lastTractBase < limit)) {
+    arena->lastTract = NULL;
+    arena->lastTractBase = (Addr)0;
+  }
+
+  res = ReservoirEnsureFull(reservoir);
+  if (res == ResOK) {
+    (*arena->class->free)(base, size, pool);
+  } else {
+    AVER(ResIsAllocFailure(res));
+    ReservoirDeposit(reservoir, base, size);
+  }
+
+  EVENT_PAW(ArenaFree, arena, base, size);
+  return;
+}
+
+
+Size ArenaReserved(Arena arena)
+{
+  AVERT(Arena, arena);
+  return (*arena->class->reserved)(arena);
+}
+
+Size ArenaCommitted(Arena arena)
+{
+  AVERT(Arena, arena);
+  return arena->committed;
+}
+
+Size ArenaSpareCommitted(Arena arena)
+{
+  AVERT(Arena, arena);
+  return arena->spareCommitted;
+}
+
+Size ArenaSpareCommitLimit(Arena arena)
+{
+  AVERT(Arena, arena);
+  return arena->spareCommitLimit;
+}
+
+void ArenaSetSpareCommitLimit(Arena arena, Size limit)
+{
+  AVERT(Arena, arena);
+  /* Can't check limit, as all possible values are allowed. */
+
+  arena->spareCommitLimit = limit;
+  if (arena->spareCommitLimit < arena->spareCommitted) {
+    arena->class->spareCommitExceeded(arena);
+  }
+
+  EVENT_PW(SpareCommitLimitSet, arena, limit);
+  return;
+}
+
+/* Used by arenas which don't use spare committed memory */
+void ArenaNoSpareCommitExceeded(Arena arena)
+{
+  AVERT(Arena, arena);
+  return;
+}
+
+
+Size ArenaCommitLimit(Arena arena)
+{
+  AVERT(Arena, arena);
+  return arena->commitLimit;
+}
+
+Res ArenaSetCommitLimit(Arena arena, Size limit)
+{
+  Size committed;
+  Res res;
+
+  AVERT(Arena, arena);
+  AVER(ArenaCommitted(arena) <= arena->commitLimit);
+
+  committed = ArenaCommitted(arena);
+  if (limit < committed) {
+    /* Attempt to set the limit below current committed */
+    if (limit >= committed - arena->spareCommitted) {
+      /* could set the limit by flushing any spare committed memory */
+      arena->class->spareCommitExceeded(arena);
+      AVER(limit >= ArenaCommitted(arena));
+      arena->commitLimit = limit;
+      res = ResOK;
+    } else {
+      res = ResFAIL;
+    }
+  } else {
+    arena->commitLimit = limit;
+    res = ResOK;
+  }
+  EVENT_PWU(CommitLimitSet, arena, limit, (res == ResOK));
+  return res;
+}
+
+
+/* ArenaAvail -- return available memory in the arena */
+
+Size ArenaAvail(Arena arena)
+{
+  Size sSwap;
+
+  sSwap = ArenaReserved(arena);
+  if (sSwap > arena->commitLimit) sSwap = arena->commitLimit;
+  /* @@@@ sSwap should take actual paging file size into account */
+  return sSwap - arena->committed + arena->spareCommitted;
+}
+
+
+/* ArenaExtend -- Add a new chunk in the arena */
+
+Res ArenaExtend(Arena arena, Addr base, Size size)
+{
+  Res res;
+
+  AVERT(Arena, arena);
+  AVER(base != (Addr)0);
+  AVER(size > 0);
+
+  res = (*arena->class->extend)(arena, base, size);
+  if (res != ResOK) 
+    return res;
+
+  EVENT_PAW(ArenaExtend, arena, base, size);
+  return ResOK;
+}
+
+
+/* ArenaNoExtend -- fail to extend the arena by a chunk */
+
+Res ArenaNoExtend(Arena arena, Addr base, Size size)
+{
+  AVERT(Arena, arena);
+  AVER(base != (Addr)0);
+  AVER(size > (Size)0);
+
+  NOTREACHED;
+  return ResUNIMPL;
+}