emacs/mps/code/arenavm.c

/* arenavm.c: VIRTUAL MEMORY ARENA CLASS
 *
 * $Id$
 * Copyright (c) 2001-2016 Ravenbrook Limited.  See end of file for license.
 *
 *
 * DESIGN
 *
 * .design: See <design/arenavm/>, and <design/arena/#coop-vm>
 *
 * .vm.addr-is-star: In this file, Addr is compatible with C
 * pointers, and Count with size_t (Index), because all refer to the
 * virtual address space.
 *
 *
 * IMPROVEMENTS
 *
 * .improve.table.zone-zero: It would be better to make sure that the
 * page tables are in zone zero, since that zone is least useful for
 * GC.  (But it would change how pagesFindFreeInZones avoids allocating
 * over the tables, see .alloc.skip.)
 */

#include "boot.h"
#include "bt.h"
#include "cbs.h"
#include "mpm.h"
#include "mpsavm.h"
#include "poolmfs.h"
#include "sa.h"
#include "tract.h"
#include "vm.h"

SRCID(arenavm, "$Id$");


/* VMChunk -- chunks for VM arenas */

typedef struct VMChunkStruct *VMChunk;

#define VMChunkSig ((Sig)0x519A6B3C) /* SIGnature ARena VM Chunk */

typedef struct VMChunkStruct {
  ChunkStruct chunkStruct;      /* generic chunk */
  VMStruct vmStruct;            /* virtual memory descriptor */
  Addr overheadMappedLimit;     /* limit of pages mapped for overhead */
  SparseArrayStruct pages;      /* to manage backing store of page table */
  Sig sig;                      /* <design/sig/> */
} VMChunkStruct;

#define VMChunk2Chunk(vmchunk) (&(vmchunk)->chunkStruct)
#define VMChunkVM(vmchunk) (&(vmchunk)->vmStruct)
#define Chunk2VMChunk(chunk) PARENT(VMChunkStruct, chunkStruct, chunk)


/* VMChunkVMArena -- get the VM arena from a VM chunk */

#define VMChunkVMArena(vmchunk) \
  MustBeA(VMArena, ChunkArena(VMChunk2Chunk(vmchunk)))


/* VMArena
 *
 * See <design/arena/#coop-vm.struct.vmarena> for description.
 */

typedef struct VMArenaStruct *VMArena;

#define VMArenaSig      ((Sig)0x519A6EB3) /* SIGnature AREna VM */

typedef struct VMArenaStruct {  /* VM arena structure */
  ArenaStruct arenaStruct;
  VMStruct vmStruct;            /* VM descriptor for VM containing arena */
  char vmParams[VMParamSize];   /* VM parameter block */
  Size spareSize;               /* total size of spare pages */
  Size extendBy;                /* desired arena increment */
  Size extendMin;               /* minimum arena increment */
  ArenaVMExtendedCallback extended;
  ArenaVMContractedCallback contracted;
  RingStruct spareRing;         /* spare (free but mapped) tracts */
  Sig sig;                      /* <design/sig/> */
} VMArenaStruct;

#define VMArenaVM(vmarena) (&(vmarena)->vmStruct)


/* Forward declarations */

static Size VMPurgeSpare(Arena arena, Size size);
static void chunkUnmapSpare(Chunk chunk);
DECLARE_CLASS(Arena, VMArena, AbstractArena);
static void VMCompact(Arena arena, Trace trace);


/* VMChunkCheck -- check the consistency of a VM chunk */

ATTRIBUTE_UNUSED
static Bool VMChunkCheck(VMChunk vmchunk)
{
  Chunk chunk;

  CHECKS(VMChunk, vmchunk);
  chunk = VMChunk2Chunk(vmchunk);
  CHECKD(Chunk, chunk);
  CHECKD(VM, VMChunkVM(vmchunk));
  CHECKL(SizeIsAligned(ChunkPageSize(chunk), VMPageSize(VMChunkVM(vmchunk))));
  CHECKL(vmchunk->overheadMappedLimit <= (Addr)chunk->pageTable);
  CHECKD(SparseArray, &vmchunk->pages);
  /* SparseArrayCheck is agnostic about where the BTs live, so VMChunkCheck
     makes sure they're where they're expected to be (in the chunk). */
  CHECKL(chunk->base < (Addr)vmchunk->pages.mapped);
  CHECKL(AddrAdd(vmchunk->pages.mapped, BTSize(chunk->pages)) <=
         vmchunk->overheadMappedLimit);
  CHECKL(chunk->base < (Addr)vmchunk->pages.pages);
  CHECKL(AddrAdd(vmchunk->pages.pages, BTSize(chunk->pageTablePages)) <=
         vmchunk->overheadMappedLimit);
  /* .improve.check-table: Could check the consistency of the tables. */
  
  return TRUE;
}


/* addrOfPageDesc -- address of the page descriptor (as an Addr) */

#define addrOfPageDesc(chunk, index) \
  ((Addr)&(chunk)->pageTable[index])


/* PageTablePageIndex
 *
 * Maps from a page base address for a page occupied by the page table
 * to the index of that page in the range of pages occupied by the
 * page table.  So that
 *   PageTablePageIndex(chunk, (Addr)chunk->pageTable) == 0
 * and
 *   PageTablePageIndex(chunk,
 *                      AddrAlignUp(addrOfPageDesc(chunk->pages), pageSize)
 *     == chunk->pageTablePages
 */
#define PageTablePageIndex(chunk, pageAddr) \
  ChunkSizeToPages(chunk, AddrOffset((Addr)(chunk)->pageTable, pageAddr))


/* TablePageIndexBase
 *
 * Takes a page table page index (i.e., the index of a page occupied
 * by the page table, where the page occupied by chunk->pageTable is
 * index 0) and returns the base address of that page.
 * (Reverse of mapping defined by PageTablePageIndex.)
 */
#define TablePageIndexBase(chunk, index) \
  AddrAdd((Addr)(chunk)->pageTable, ChunkPagesToSize(chunk, index))


/* VMArenaCheck -- check the consistency of an arena structure */

ATTRIBUTE_UNUSED
static Bool VMArenaCheck(VMArena vmArena)
{
  Arena arena;
  VMChunk primary;

  CHECKS(VMArena, vmArena);
  arena = MustBeA(AbstractArena, vmArena);
  CHECKD(Arena, arena);
  /* spare pages are committed, so must be less spare than committed. */
  CHECKL(vmArena->spareSize <= arena->committed);

  CHECKL(vmArena->extendBy > 0);
  CHECKL(vmArena->extendMin <= vmArena->extendBy);

  if (arena->primary != NULL) {
    primary = Chunk2VMChunk(arena->primary);
    CHECKD(VMChunk, primary);
    /* We could iterate over all chunks accumulating an accurate */
    /* count of committed, but we don't have all day. */
    CHECKL(VMMapped(VMChunkVM(primary)) <= arena->committed);
  }
  
  CHECKD_NOSIG(Ring, &vmArena->spareRing);

  /* FIXME: Can't check VMParams */

  return TRUE;
}


/* VMArenaDescribe -- describe the VMArena
 */
static Res VMArenaDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
  Arena arena = CouldBeA(AbstractArena, inst);
  VMArena vmArena = CouldBeA(VMArena, arena);
  Res res;

  if (!TESTC(VMArena, vmArena))
    return ResPARAM;
  if (stream == NULL)
    return ResPARAM;

  res = NextMethod(Inst, VMArena, describe)(inst, stream, depth);
  if (res != ResOK)
    return res;

  res = WriteF(stream, depth,
               "  spareSize:     $U\n", (WriteFU)vmArena->spareSize,
               NULL);
  if(res != ResOK)
    return res;

  /* TODO: incomplete -- some fields are not Described */

  return ResOK;
}



/* VM indirect functions
 *
 * These functions should be used to map and unmap within the arena.
 * They are responsible for maintaining vmArena->committed, and for
 * checking that the commit limit does not get exceeded.
 */
static Res vmArenaMap(VMArena vmArena, VM vm, Addr base, Addr limit)
{
  Arena arena = MustBeA(AbstractArena, vmArena);
  Size size = AddrOffset(base, limit);
  Res res;

  /* no checking as function is local to module */

  /* committed can't overflow (since we can't commit more memory than */
  /* address space), but we're paranoid. */
  AVER(arena->committed < arena->committed + size);
  /* check against commit limit */
  if (arena->commitLimit < arena->committed + size)
    return ResCOMMIT_LIMIT;

  res = VMMap(vm, base, limit);
  if (res != ResOK)
    return res;
  arena->committed += size;
  return ResOK;
}


static void vmArenaUnmap(VMArena vmArena, VM vm, Addr base, Addr limit)
{
  Arena arena = MustBeA(AbstractArena, vmArena);
  Size size = AddrOffset(base, limit);

  /* no checking as function is local to module */
  AVER(size <= arena->committed);

  VMUnmap(vm, base, limit);
  arena->committed -= size;
}


/* VMChunkCreate -- create a chunk
 *
 * chunkReturn, return parameter for the created chunk.
 * vmArena, the parent VMArena.
 * size, approximate amount of virtual address that the chunk should reserve.
 */
static Res VMChunkCreate(Chunk *chunkReturn, VMArena vmArena, Size size)
{
  Arena arena = MustBeA(AbstractArena, vmArena);
  Res res;
  Addr base, limit, chunkStructLimit;
  VMStruct vmStruct;
  VM vm = &vmStruct;
  BootBlockStruct bootStruct;
  BootBlock boot = &bootStruct;
  VMChunk vmChunk;
  void *p;

  AVER(chunkReturn != NULL);
  AVERT(VMArena, vmArena);
  AVER(size > 0);

  res = VMInit(vm, size, ArenaGrainSize(arena), vmArena->vmParams);
  if (res != ResOK)
    goto failVMInit;

  base = VMBase(vm);
  limit = VMLimit(vm);

  res = BootBlockInit(boot, (void *)base, (void *)limit);
  if (res != ResOK)
    goto failBootInit;

  /* .overhead.chunk-struct: Allocate and map the chunk structure. */
  res = BootAlloc(&p, boot, sizeof(VMChunkStruct), MPS_PF_ALIGN);
  if (res != ResOK)
    goto failChunkAlloc;
  vmChunk = p;
  /* Calculate the limit of the grain where the chunkStruct resides. */
  chunkStructLimit = AddrAlignUp((Addr)(vmChunk + 1), ArenaGrainSize(arena));
  res = vmArenaMap(vmArena, vm, base, chunkStructLimit);
  if (res != ResOK)
    goto failChunkMap;
  vmChunk->overheadMappedLimit = chunkStructLimit;

  /* Copy VM descriptor into its place in the chunk. */
  VMCopy(VMChunkVM(vmChunk), vm);
  res = ChunkInit(VMChunk2Chunk(vmChunk), arena, base, limit,
                  VMReserved(VMChunkVM(vmChunk)), boot);
  if (res != ResOK)
    goto failChunkInit;

  BootBlockFinish(boot);

  vmChunk->sig = VMChunkSig;
  AVERT(VMChunk, vmChunk);

  *chunkReturn = VMChunk2Chunk(vmChunk);
  return ResOK;

failChunkInit:
  VMUnmap(vm, VMBase(vm), chunkStructLimit);
failChunkMap:
failChunkAlloc:
failBootInit:
  VMFinish(vm);
failVMInit:
  return res;
}


/* VMChunkInit -- initialize a VMChunk */

static Res VMChunkInit(Chunk chunk, BootBlock boot)
{
  VMChunk vmChunk;
  Addr overheadLimit;
  void *p;
  Res res;
  BT saMapped, saPages;

  /* chunk is supposed to be uninitialized, so don't check it. */
  vmChunk = Chunk2VMChunk(chunk);
  AVERT(BootBlock, boot);
  
  /* .overhead.sa-mapped: Chunk overhead for sparse array 'mapped' table. */
  res = BootAlloc(&p, boot, BTSize(chunk->pages), MPS_PF_ALIGN);
  if (res != ResOK)
    goto failSaMapped;
  saMapped = p;
  
  /* .overhead.sa-pages: Chunk overhead for sparse array 'pages' table. */
  res = BootAlloc(&p, boot, BTSize(chunk->pageTablePages), MPS_PF_ALIGN);
  if (res != ResOK)
    goto failSaPages;
  saPages = p;
  
  overheadLimit = AddrAdd(chunk->base, (Size)BootAllocated(boot));

  /* .overhead.page-table: Put the page table as late as possible, as
   * in VM systems we don't want to map it. */
  res = BootAlloc(&p, boot, chunk->pageTablePages << chunk->pageShift, chunk->pageSize);
  if (res != ResOK)
    goto failAllocPageTable;
  chunk->pageTable = p;

  /* Map memory for the bit tables. */
  if (vmChunk->overheadMappedLimit < overheadLimit) {
    overheadLimit = AddrAlignUp(overheadLimit, ChunkPageSize(chunk));
    res = vmArenaMap(VMChunkVMArena(vmChunk), VMChunkVM(vmChunk),
                     vmChunk->overheadMappedLimit, overheadLimit);
    if (res != ResOK)
      goto failTableMap;
    vmChunk->overheadMappedLimit = overheadLimit;
  }

  SparseArrayInit(&vmChunk->pages,
                  chunk->pageTable,
                  sizeof(PageUnion),
                  chunk->pages,
                  saMapped, saPages, VMChunkVM(vmChunk));

  return ResOK;

  /* .no-clean: No clean-ups needed for boot, as we will discard the chunk. */
failTableMap:
failSaPages:
failAllocPageTable:
failSaMapped:
  return res;
}


/* vmChunkDestroy -- destroy a VMChunk */

static Bool vmChunkDestroy(Tree tree, void *closure)
{
  Chunk chunk;
  VMChunk vmChunk;

  AVERT(Tree, tree);
  AVER(closure == UNUSED_POINTER);
  UNUSED(closure);

  chunk = ChunkOfTree(tree);
  AVERT(Chunk, chunk);
  vmChunk = Chunk2VMChunk(chunk);
  AVERT(VMChunk, vmChunk);
  
  chunkUnmapSpare(chunk);
  
  SparseArrayFinish(&vmChunk->pages);
  
  vmChunk->sig = SigInvalid;
  ChunkFinish(chunk);

  return TRUE;
}


/* VMChunkFinish -- finish a VMChunk */

static void VMChunkFinish(Chunk chunk)
{
  VMStruct vmStruct;
  VM vm = &vmStruct;
  VMChunk vmChunk = Chunk2VMChunk(chunk);

  /* Copy VM descriptor to stack-local storage so that we can continue
   * using the descriptor after the VM has been unmapped. */
  VMCopy(vm, VMChunkVM(vmChunk));

  vmArenaUnmap(VMChunkVMArena(vmChunk), vm,
               VMBase(vm), vmChunk->overheadMappedLimit);

  /* No point in finishing the other fields, since they are unmapped. */

  VMFinish(vm);
}


/* VMArenaVarargs -- parse obsolete varargs */

static void VMArenaVarargs(ArgStruct args[MPS_ARGS_MAX], va_list varargs)
{
  args[0].key = MPS_KEY_ARENA_SIZE;
  args[0].val.size = va_arg(varargs, Size);
  args[1].key = MPS_KEY_ARGS_END;
  AVERT(ArgList, args);
}


/* 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);
}


/* vmArenaChunkSize -- compute chunk size
 *
 * Compute the size of the smallest chunk that has size bytes of usable
 * address space (that is, after all overheads are accounted for).
 *
 * If successful, update *chunkSizeReturn with the computed chunk size
 * and return ResOK. If size is too large for a chunk, leave
 * *chunkSizeReturn unchanged and return ResRESOURCE.
 */
static Res vmArenaChunkSize(Size *chunkSizeReturn, VMArena vmArena, Size size)
{
  Size grainSize;               /* Arena grain size. */
  Shift grainShift;             /* The corresponding Shift. */
  Count pages;                  /* Number of usable pages in chunk. */
  Size pageTableSize;           /* Size of the page table. */
  Count pageTablePages;         /* Number of pages in the page table. */
  Size chunkSize;               /* Size of the chunk. */
  Size overhead;                /* Total overheads for the chunk. */

  AVER(chunkSizeReturn != NULL);
  AVERT(VMArena, vmArena);
  AVER(size > 0);

  grainSize = ArenaGrainSize(MustBeA(AbstractArena, vmArena));
  grainShift = SizeLog2(grainSize);

  overhead = 0;
  do {
    chunkSize = size + overhead;
    AVER(SizeIsAligned(chunkSize, grainSize));

    /* See .overhead.chunk-struct. */
    overhead = SizeAlignUp(sizeof(VMChunkStruct), MPS_PF_ALIGN);

    /* See <code/tract.c#overhead.pages>, */
    pages = chunkSize >> grainShift;
    overhead += SizeAlignUp(BTSize(pages), MPS_PF_ALIGN);

    /* See .overhead.sa-mapped. */
    overhead += SizeAlignUp(BTSize(pages), MPS_PF_ALIGN);

    /* See .overhead.sa-pages. */
    pageTableSize = SizeAlignUp(pages * sizeof(PageUnion), grainSize);
    pageTablePages = pageTableSize >> grainShift;
    overhead += SizeAlignUp(BTSize(pageTablePages), MPS_PF_ALIGN);

    /* See .overhead.page-table. */
    overhead = SizeAlignUp(overhead, grainSize);
    overhead += SizeAlignUp(pageTableSize, grainSize);

    if (SizeMAX - overhead < size)
      return ResRESOURCE;
  } while (chunkSize < size + overhead);

  *chunkSizeReturn = chunkSize;
  return ResOK;
}


/* VMArenaCreate -- 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 VMArenaCreate(Arena *arenaReturn, ArgList args)
{
  Size size = VM_ARENA_SIZE_DEFAULT; /* initial arena size */
  Align grainSize = MPS_PF_ALIGN; /* arena grain size */
  Size pageSize = PageSize(); /* operating system page size */
  Size chunkSize; /* size actually created */
  Size vmArenaSize; /* aligned size of VMArenaStruct */
  Res res;
  VMArena vmArena;
  Arena arena;
  VMStruct vmStruct;
  VM vm = &vmStruct;
  Chunk chunk;
  mps_arg_s arg;
  char vmParams[VMParamSize];
  
  AVER(arenaReturn != NULL);
  AVERT(ArgList, args);

  if (ArgPick(&arg, args, MPS_KEY_ARENA_GRAIN_SIZE))
    grainSize = arg.val.size;
  if (grainSize < pageSize)
    /* Make it easier to write portable programs by rounding up. */
    grainSize = pageSize;
  AVERT(ArenaGrainSize, grainSize);
  AVER(sizeof(RingStruct) < grainSize); /* .spare-ring.at-base */

  if (ArgPick(&arg, args, MPS_KEY_ARENA_SIZE))
    size = arg.val.size;
  if (size < grainSize * MPS_WORD_WIDTH)
    /* There has to be enough room in the chunk for a full complement of
       zones. Make it easier to write portable programs by rounding up. */
    size = grainSize * MPS_WORD_WIDTH;
  
  /* Parse remaining arguments, if any, into VM parameters. We must do
     this into some stack-allocated memory for the moment, since we
     don't have anywhere else to put it. It gets copied later. */
  res = VMParamFromArgs(vmParams, sizeof(vmParams), args);
  if (res != ResOK)
    goto failVMInit;

  /* Create a VM to hold the arena and map it. Store descriptor on the
     stack until we have the arena to put it in. */
  vmArenaSize = SizeAlignUp(sizeof(VMArenaStruct), MPS_PF_ALIGN);
  res = VMInit(vm, vmArenaSize, grainSize, vmParams);
  if (res != ResOK)
    goto failVMInit;
  res = VMMap(vm, VMBase(vm), VMLimit(vm));
  if (res != ResOK)
    goto failVMMap;
  vmArena = (VMArena)VMBase(vm);

  arena = CouldBeA(AbstractArena, vmArena);

  res = NextMethod(Arena, VMArena, init)(arena, grainSize, args);
  if (res != ResOK)
    goto failArenaInit;
  SetClassOfPoly(arena, CLASS(VMArena));
  AVER(vmArena == MustBeA(VMArena, arena));
  
  arena->reserved = VMReserved(vm);
  arena->committed = VMMapped(vm);

  /* Copy VM descriptor into its place in the arena. */
  VMCopy(VMArenaVM(vmArena), vm);
  vmArena->spareSize = 0;
  RingInit(&vmArena->spareRing);

  /* Copy the stack-allocated VM parameters into their home in the VMArena. */
  AVER(sizeof(vmArena->vmParams) == sizeof(vmParams));
  (void)mps_lib_memcpy(vmArena->vmParams, vmParams, sizeof(vmArena->vmParams));

  /* <design/arena/#coop-vm.struct.vmarena.extendby.init> */
  vmArena->extendBy = size;
  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, size);
  if (res != ResOK)
    goto failChunkCreate;

#if defined(AVER_AND_CHECK_ALL)
  /* Check the computation of the chunk size in vmArenaChunkSize, now
   * that we have the actual chunk for comparison. Note that
   * vmArenaChunkSize computes the smallest size with a given number
   * of usable bytes -- the actual chunk may be one grain larger. */
  {
    Size usableSize, computedChunkSize;
    usableSize = AddrOffset(PageIndexBase(chunk, chunk->allocBase),
                            chunk->limit);
    res = vmArenaChunkSize(&computedChunkSize, vmArena, usableSize);
    AVER(res == ResOK);
    AVER(computedChunkSize == ChunkSize(chunk)
         || computedChunkSize + grainSize == ChunkSize(chunk));
  }
#endif

  /* .zoneshift: Set the zone shift to divide the chunk into the same */
  /* number of stripes as will fit into a reference set (the number of */
  /* bits in a word).  Fail if the chunk is so small stripes are smaller */
  /* than pages.  Note that some zones are discontiguous in the chunk if */
  /* the size is not a power of 2.  See <design/arena/#class.fields>. */
  chunkSize = ChunkSize(chunk);
  arena->zoneShift = SizeFloorLog2(chunkSize >> MPS_WORD_SHIFT);
  AVER(ChunkPageSize(chunk) == ArenaGrainSize(arena));

  AVERT(VMArena, vmArena);
  EVENT3(ArenaCreateVM, arena, size, chunkSize);

  vmArena->extended(arena, chunk->base, chunkSize);
  
  *arenaReturn = arena;
  return ResOK;

failChunkCreate:
  NextMethod(Inst, VMArena, finish)(MustBeA(Inst, arena));
failArenaInit:
  VMUnmap(vm, VMBase(vm), VMLimit(vm));
failVMMap:
  VMFinish(vm);
failVMInit:
  return res;
}


/* VMArenaDestroy -- destroy the arena */

static void VMArenaDestroy(Arena arena)
{
  VMArena vmArena = MustBeA(VMArena, arena);
  VMStruct vmStruct;
  VM vm = &vmStruct;

  EVENT1(ArenaDestroy, vmArena);

  /* Destroy all chunks, including the primary. See
   * <design/arena/#chunk.delete> */
  arena->primary = NULL;
  TreeTraverseAndDelete(&arena->chunkTree, vmChunkDestroy,
                        UNUSED_POINTER);
  
  /* Destroying the chunks should have purged and removed all spare pages. */
  RingFinish(&vmArena->spareRing);

  /* Destroying the chunks should leave only the arena's own VM. */
  AVER(arena->reserved == VMReserved(VMArenaVM(vmArena)));
  AVER(arena->committed == VMMapped(VMArenaVM(vmArena)));

  vmArena->sig = SigInvalid;

  NextMethod(Inst, VMArena, finish)(MustBeA(Inst, arena));

  /* Copy VM descriptor to stack-local storage so that we can continue
   * using the descriptor after the VM has been unmapped. */
  VMCopy(vm, VMArenaVM(vmArena));
  VMUnmap(vm, VMBase(vm), VMLimit(vm));
  VMFinish(vm);
}


/* VMArenaGrow -- Extend the arena by making a new chunk
 *
 * size specifies how much we wish to allocate after the extension.
 * pref specifies the preference for the location of the allocation.
 */
static Res VMArenaGrow(Arena arena, LocusPref pref, Size size)
{
  VMArena vmArena = MustBeA(VMArena, arena);
  Chunk newChunk;
  Size chunkSize;
  Size chunkMin;
  Res res;
  
  /* TODO: Ensure that extended arena will be able to satisfy pref. */
  AVERT(LocusPref, pref);
  UNUSED(pref);

  res = vmArenaChunkSize(&chunkMin, vmArena, size);
  if (res != ResOK)
    return res;
  chunkSize = vmArena->extendBy;

  EVENT3(vmArenaExtendStart, size, chunkSize, ArenaReserved(arena));

  /* .chunk-create.fail: If we fail, try again with a smaller size */
  {
    unsigned fidelity = 8;  /* max fraction of addr-space we may 'waste' */
    Size chunkHalf;
    Size sliceSize;
    
    if (vmArena->extendMin > chunkMin)
      chunkMin = vmArena->extendMin;
    if (chunkSize < chunkMin)
      chunkSize = chunkMin;
    
    res = ResRESOURCE;
    for(;; chunkSize = chunkHalf) {
      chunkHalf = chunkSize / 2;
      sliceSize = chunkHalf / fidelity;
      AVER(sliceSize > 0);
      
      /* remove slices, down to chunkHalf but no further */
      for(; chunkSize > chunkHalf; chunkSize -= sliceSize) {
        if(chunkSize < chunkMin) {
          EVENT2(vmArenaExtendFail, chunkMin, ArenaReserved(arena));
          return res;
        }
        res = VMChunkCreate(&newChunk, vmArena, chunkSize);
        if(res == ResOK)
          goto vmArenaGrow_Done;
      }
    }
  }
  
vmArenaGrow_Done:
  EVENT2(vmArenaExtendDone, chunkSize, ArenaReserved(arena));
  vmArena->extended(arena,
                    newChunk->base,
                    AddrOffset(newChunk->base, newChunk->limit));
      
  return res;
}


/* pageState -- determine page state, even if unmapped
 *
 * Parts of the page table may be unmapped if their corresponding pages are
 * free.
 */

static unsigned pageState(VMChunk vmChunk, Index pi)
{
  Chunk chunk = VMChunk2Chunk(vmChunk);
  if (SparseArrayIsMapped(&vmChunk->pages, pi))
    return PageState(ChunkPage(chunk, pi));
  return PageStateFREE;
}


/* sparePageRing -- get the spare ring node for a spare page
 *
 * .spare-ring.at-base: The spare ring node is stored at the base of
 * the spare page. (Since it's spare, the memory is not needed for any
 * other purpose.)
 */

#define sparePageRing(chunk, pi) ((Ring)PageIndexBase(chunk, pi))


/* sparePageRelease -- releases a spare page
 *
 * Either to allocate it or to purge it.
 *
 * Temporarily leaves the page table entry in an inconsistent state:
 * the state is PageStateSPARE but the page is no longer on the spare
 * ring.
 */

static void sparePageRelease(VMChunk vmChunk, Index pi)
{
  Chunk chunk = VMChunk2Chunk(vmChunk);
  Arena arena = ChunkArena(chunk);
  Ring spareRing = sparePageRing(chunk, pi);

  AVER(PageState(ChunkPage(chunk, pi)) == PageStateSPARE);
  AVER(arena->spareCommitted >= ChunkPageSize(chunk));
  AVERT(Ring, spareRing);

  arena->spareCommitted -= ChunkPageSize(chunk);
  RingRemove(spareRing);
}


static Res pageDescMap(VMChunk vmChunk, Index basePI, Index limitPI)
{
  Size before = VMMapped(VMChunkVM(vmChunk));
  Arena arena = MustBeA(AbstractArena, VMChunkVMArena(vmChunk));
  Res res = SparseArrayMap(&vmChunk->pages, basePI, limitPI);
  Size after = VMMapped(VMChunkVM(vmChunk));
  AVER(before <= after);
  arena->committed += after - before;
  return res;
}

static void pageDescUnmap(VMChunk vmChunk, Index basePI, Index limitPI)
{
  Size size, after;
  Size before = VMMapped(VMChunkVM(vmChunk));
  Arena arena = MustBeA(AbstractArena, VMChunkVMArena(vmChunk));
  SparseArrayUnmap(&vmChunk->pages, basePI, limitPI);
  after = VMMapped(VMChunkVM(vmChunk));
  AVER(after <= before);
  size = before - after;
  AVER(arena->committed >= size);
  arena->committed -= size;
}


/* pagesMarkAllocated -- Mark the pages allocated */

static Res pagesMarkAllocated(VMArena vmArena, VMChunk vmChunk,
                              Index basePI, Count pages, Pool pool)
{
  Index cursor, i, j, k;
  Index limitPI;
  Chunk chunk = VMChunk2Chunk(vmChunk);
  Res res;
  
  limitPI = basePI + pages;
  AVER(limitPI <= chunk->pages);

  /* NOTE: We could find a reset bit range in vmChunk->pages.pages in order
     to skip across hundreds of pages at once.  That could speed up really
     big block allocations (hundreds of pages long). */

  cursor = basePI;
  while (BTFindLongResRange(&j, &k, vmChunk->pages.mapped, cursor, limitPI, 1)) {
    for (i = cursor; i < j; ++i) {
      sparePageRelease(vmChunk, i);
      PageAlloc(chunk, i, pool);
    }
    res = pageDescMap(vmChunk, j, k);
    if (res != ResOK)
      goto failSAMap;
    res = vmArenaMap(vmArena, VMChunkVM(vmChunk),
                     PageIndexBase(chunk, j), PageIndexBase(chunk, k));
    if (res != ResOK)
      goto failVMMap;
    for (i = j; i < k; ++i) {
      PageInit(chunk, i);
      PageAlloc(chunk, i, pool);
    }
    cursor = k;
    if (cursor == limitPI)
      return ResOK;
  }
  for (i = cursor; i < limitPI; ++i) {
    sparePageRelease(vmChunk, i);
    PageAlloc(chunk, i, pool);
  }
  return ResOK;

failVMMap:
  pageDescUnmap(vmChunk, j, k);
failSAMap:
  /* region from basePI to j needs deallocating */
  /* TODO: Consider making pages spare instead, then purging. */
  if (basePI < j) {
    vmArenaUnmap(vmArena, VMChunkVM(vmChunk),
                 PageIndexBase(chunk, basePI),
                 PageIndexBase(chunk, j));
    for (i = basePI; i < j; ++i)
      PageFree(chunk, i);
    pageDescUnmap(vmChunk, basePI, j);
  }
  return res;
}

static Res VMPagesMarkAllocated(Arena arena, Chunk chunk,
                                Index baseIndex, Count pages, Pool pool)
{
  Res res;
  VMArena vmArena = MustBeA(VMArena, arena);

  AVERT(Arena, arena);
  AVERT(Chunk, chunk);
  AVER(chunk->allocBase <= baseIndex);
  AVER(pages > 0);
  AVER(baseIndex + pages <= chunk->pages);
  AVERT(Pool, pool);

  res = pagesMarkAllocated(vmArena,
                           Chunk2VMChunk(chunk),
                           baseIndex,
                           pages,
                           pool);
  /* TODO: Could this loop be pushed down into vmArenaMap? */
  while (res != ResOK) {
    /* Try purging spare pages in the hope that the OS will give them back
       at the new address.  Will eventually run out of spare pages, so this
       loop will terminate. */
    /* TODO: Investigate implementing VMRemap so that we can guarantee
       success if we have enough spare pages. */
    if (VMPurgeSpare(arena, pages * ChunkPageSize(chunk)) == 0)
      break;
    res = pagesMarkAllocated(vmArena,
                             Chunk2VMChunk(chunk),
                             baseIndex,
                             pages,
                             pool);
  }
  return res;
}


static Bool VMChunkPageMapped(Chunk chunk, Index index)
{
  VMChunk vmChunk;
  AVERT(Chunk, chunk);
  AVER(index < chunk->pages);
  vmChunk = Chunk2VMChunk(chunk);
  return BTGet(vmChunk->pages.mapped, index);
}


/* chunkUnmapAroundPage -- unmap spare pages in a chunk including this one
 *
 * Unmap the spare page passed, and possibly other pages in the chunk,
 * unmapping at least the size passed if available.  The amount unmapped
 * may exceed the size by up to one page.  Returns the amount of memory
 * unmapped.
 *
 * To minimse unmapping calls, the page passed is coalesced with spare
 * pages above and below, even though these may have been more recently
 * made spare.
 */

static Size chunkUnmapAroundPage(Chunk chunk, Size size, Page page)
{
  VMChunk vmChunk;
  Size purged = 0;
  Size pageSize;
  Index basePI, limitPI;

  AVERT(Chunk, chunk);
  vmChunk = Chunk2VMChunk(chunk);
  AVERT(VMChunk, vmChunk);
  AVER(PageState(page) == PageStateSPARE);
  /* size is arbitrary */

  pageSize = ChunkPageSize(chunk);

  basePI = (Index)(page - chunk->pageTable);
  AVER(basePI < chunk->pages); /* page is within chunk's page table */
  limitPI = basePI;

  do {
    sparePageRelease(vmChunk, limitPI);
    ++limitPI;
    purged += pageSize;
  } while (purged < size &&
           limitPI < chunk->pages &&
           pageState(vmChunk, limitPI) == PageStateSPARE);
  while (purged < size &&
         basePI > 0 &&
         pageState(vmChunk, basePI - 1) == PageStateSPARE) {
    --basePI;
    sparePageRelease(vmChunk, basePI);
    purged += pageSize;
  }

  vmArenaUnmap(VMChunkVMArena(vmChunk),
               VMChunkVM(vmChunk),
               PageIndexBase(chunk, basePI),
               PageIndexBase(chunk, limitPI));

  pageDescUnmap(vmChunk, basePI, limitPI);

  return purged;
}


/* arenaUnmapSpare -- return spare pages to the OS
 *
 * The size is the desired amount to purge, and the amount that was purged is
 * returned.  If filter is not NULL, then only pages within that chunk are
 * unmapped.
 */

static Size arenaUnmapSpare(Arena arena, Size size, Chunk filter)
{
  VMArena vmArena = MustBeA(VMArena, arena);
  Ring node;
  Size purged = 0;

  if (filter != NULL)
    AVERT(Chunk, filter);

  /* Start by looking at the oldest page on the spare ring, to try to
     get some LRU behaviour from the spare pages cache. */
  /* RING_FOR won't work here, because chunkUnmapAroundPage deletes
     and unmaps "next" and possibly many other entries from the
     spareRing. However, we know that it won't delete "node", because
     either "node" is &vmArena->spareRing (which is not in any chunk),
     or else "node" and "next" are in discontiguous spans of spare
     pages (otherwise "node" would have been deleted on the previous
     iteration). */
  node = &vmArena->spareRing;
  while (RingNext(node) != &vmArena->spareRing && purged < size) {
    Ring next = RingNext(node);
    Chunk chunk = NULL; /* suppress uninit warning */
    Bool b = ChunkOfAddr(&chunk, arena, (Addr)next); /* .spare-ring.at-base */
    AVER(b);
    if (filter == NULL || chunk == filter) {
      Index pi = IndexOfAddr(chunk, (Addr)next);
      Page page = ChunkPage(chunk, pi);
      purged += chunkUnmapAroundPage(chunk, size - purged, page);
      /* chunkUnmapAroundPage must delete the page it's passed from the ring,
         or we can't make progress and there will be an infinite loop */
      AVER(RingNext(node) != next);
    } else {
      node = next;
    }
  }

  return purged;
}

static Size VMPurgeSpare(Arena arena, Size size)
{
  return arenaUnmapSpare(arena, size, NULL);
}


/* chunkUnmapSpare -- unmap all spare pages in a chunk */

static void chunkUnmapSpare(Chunk chunk)
{
  AVERT(Chunk, chunk);
  (void)arenaUnmapSpare(ChunkArena(chunk), ChunkSize(chunk), chunk);
}


/* VMFree -- free a region in the arena */

static void VMFree(Addr base, Size size, Pool pool)
{
  Arena arena;
  VMArena vmArena;
  Chunk chunk = NULL;           /* suppress "may be used uninitialized" */
  Count pages;
  Index pi, piBase, piLimit;
  Bool foundChunk;

  AVER(base != NULL);
  AVER(size > (Size)0);
  AVERT(Pool, pool);
  arena = PoolArena(pool);
  vmArena = MustBeA(VMArena, arena);

  /* All chunks have same pageSize. */
  AVER(SizeIsAligned(size, ChunkPageSize(arena->primary)));
  AVER(AddrIsAligned(base, ChunkPageSize(arena->primary)));

  foundChunk = ChunkOfAddr(&chunk, arena, base);
  AVER(foundChunk);

  /* Calculate the number of pages in the region */
  pages = ChunkSizeToPages(chunk, size);
  piBase = INDEX_OF_ADDR(chunk, base);
  piLimit = piBase + pages;
  AVER(piBase < piLimit);
  AVER(piLimit <= chunk->pages);

  /* loop from pageBase to pageLimit-1 inclusive */
  /* Finish each Tract found, then convert them to spare pages. */
  for(pi = piBase; pi < piLimit; ++pi) {
    Page page = ChunkPage(chunk, pi);
    Tract tract = PageTract(page);
    Ring spareRing;
    
    AVER(TractPool(tract) == pool);
    TractFinish(tract);

    PageSetPool(page, NULL);
    PageSetType(page, PageStateSPARE);
    spareRing = sparePageRing(chunk, pi);
    RingInit(spareRing);
    RingAppend(&vmArena->spareRing, spareRing);
  }
  arena->spareCommitted += ChunkPagesToSize(chunk, piLimit - piBase);
  BTResRange(chunk->allocTable, piBase, piLimit);

  /* Consider returning memory to the OS. */
  /* TODO: Chunks are only destroyed when ArenaCompact is called, and
     that is only called from traceReclaim. Should consider destroying
     chunks here. See job003815. */
  if (arena->spareCommitted > arena->spareCommitLimit) {
    /* Purge half of the spare memory, not just the extra sliver, so
       that we return a reasonable amount of memory in one go, and avoid
       lots of small unmappings, each of which has an overhead. */
    /* TODO: Consider making this time-based. */
    /* TODO: Consider making this smarter about the overheads tradeoff. */
    Size toPurge = arena->spareCommitted - arena->spareCommitLimit / 2;
    (void)VMPurgeSpare(arena, toPurge);
  }
}


/* vmChunkCompact -- delete chunk if empty and not primary */

static Bool vmChunkCompact(Tree tree, void *closure)
{
  Chunk chunk;
  Arena arena = closure;
  VMArena vmArena = MustBeA(VMArena, arena);

  AVERT(Tree, tree);

  chunk = ChunkOfTree(tree);
  AVERT(Chunk, chunk);
  if(chunk != arena->primary
     && BTIsResRange(chunk->allocTable, 0, chunk->pages))
  {
    Addr base = chunk->base;
    Size size = ChunkSize(chunk);
    /* Callback before destroying the chunk, as the arena is (briefly)
       invalid afterwards. See job003893. */
    (*vmArena->contracted)(arena, base, size);
    vmChunkDestroy(tree, UNUSED_POINTER);
    return TRUE;
  } else {
    /* Keep this chunk. */
    return FALSE;
  }
}


static void VMCompact(Arena arena, Trace trace)
{
  STATISTIC_DECL(Size vmem1)

  AVERT(Trace, trace);

  STATISTIC(vmem1 = ArenaReserved(arena));

  /* Destroy chunks that are completely free, but not the primary
   * chunk. See <design/arena/#chunk.delete>
   * TODO: add hysteresis here. See job003815. */
  TreeTraverseAndDelete(&arena->chunkTree, vmChunkCompact, arena);

  STATISTIC({
    Size vmem0 = trace->preTraceArenaReserved;
    Size vmem2 = ArenaReserved(arena);

    /* VMCompact event: emit for collections where chunks were gained
     * or lost during the collection. */
    if (vmem0 != vmem1 || vmem1 != vmem2)
      EVENT3(VMCompact, vmem0, vmem1, vmem2);
  });
}

mps_res_t mps_arena_vm_growth(mps_arena_t mps_arena,
                              size_t mps_desired, size_t mps_minimum)
{
  Arena arena = (Arena)mps_arena;
  Size desired = (Size)mps_desired;
  Size minimum = (Size)mps_minimum;
  VMArena vmArena;
  
  ArenaEnter(arena);
  
  AVERT(Arena, arena);
  vmArena = MustBeA(VMArena, arena);
  
  /* Must desire at least the minimum increment! */
  AVER(desired >= minimum);
  
  vmArena->extendBy = desired;
  vmArena->extendMin = minimum;
  
  ArenaLeave(arena);
  
  return MPS_RES_OK;
}


/* VMArenaClass  -- The VM arena class definition */

DEFINE_CLASS(Arena, VMArena, klass)
{
  INHERIT_CLASS(klass, VMArena, AbstractArena);
  klass->instClassStruct.describe = VMArenaDescribe;
  klass->size = sizeof(VMArenaStruct);
  klass->varargs = VMArenaVarargs;
  klass->create = VMArenaCreate;
  klass->destroy = VMArenaDestroy;
  klass->purgeSpare = VMPurgeSpare;
  klass->grow = VMArenaGrow;
  klass->free = VMFree;
  klass->chunkInit = VMChunkInit;
  klass->chunkFinish = VMChunkFinish;
  klass->compact = VMCompact;
  klass->pagesMarkAllocated = VMPagesMarkAllocated;
  klass->chunkPageMapped = VMChunkPageMapped;
  AVERT(ArenaClass, klass);
}


/* mps_arena_class_vm -- return the arena class VM */

mps_arena_class_t mps_arena_class_vm(void)
{
  return (mps_arena_class_t)CLASS(VMArena);
}


/* C. COPYRIGHT AND LICENSE
 *
 * Copyright (C) 2001-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
 * All rights reserved.  This is an open source license.  Contact
 * Ravenbrook for commercial licensing options.
 * 
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 * 
 * 1. Redistributions of source code must retain the above copyright
 * notice, this list of conditions and the following disclaimer.
 * 
 * 2. Redistributions in binary form must reproduce the above copyright
 * notice, this list of conditions and the following disclaimer in the
 * documentation and/or other materials provided with the distribution.
 * 
 * 3. Redistributions in any form must be accompanied by information on how
 * to obtain complete source code for this software and any accompanying
 * software that uses this software.  The source code must either be
 * included in the distribution or be available for no more than the cost
 * of distribution plus a nominal fee, and must be freely redistributable
 * under reasonable conditions.  For an executable file, complete source
 * code means the source code for all modules it contains. It does not
 * include source code for modules or files that typically accompany the
 * major components of the operating system on which the executable file
 * runs.
 * 
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
 * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
 * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
 * PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
 * COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
 * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
 * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
 * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */