mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-03-26 08:41:47 -07:00
Code Issues Projects Releases Wiki Activity

Catch-up merge from master sources to branch/2016-04-12/job004000.

Browse source 
Copied from Perforce
 Change: 192187
 ServerID: perforce.ravenbrook.com
This commit is contained in:
Gareth Rees 2016-09-05 16:01:17 +01:00
commit 331ec20beb
133 changed files with 1748 additions and 1305 deletions
Download patch file Download diff file Expand all files Collapse all files

2
mps/Makefile.in
View file

@ -71,7 +71,7 @@ make-install-dirs:
install: @INSTALL_TARGET@
test-make-build:
$(MAKE) $(TARGET_OPTS) testci testratio
$(MAKE) $(TARGET_OPTS) testci testratio testscheme
$(MAKE) -C code -f anan$(MPS_BUILD_NAME).gmk VARIETY=cool clean testansi
$(MAKE) -C code -f anan$(MPS_BUILD_NAME).gmk VARIETY=cool CFLAGS="-DCONFIG_POLL_NONE" clean testpollnone

13
mps/code/amcssth.c
View file

@ -120,13 +120,17 @@ typedef struct closure_s {
static void *kid_thread(void *arg)
{
void *marker = ▮
mps_thr_t thread;
mps_thr_t thread1, thread2;
mps_root_t reg_root;
mps_ap_t ap;
closure_t cl = arg;
die(mps_thread_reg(&thread, (mps_arena_t)arena), "thread_reg");
die(mps_root_create_thread(&reg_root, arena, thread, marker),
/* Register the thread twice to check this is supported -- see
* <design/thread-manager/#req.register.multi>
*/
die(mps_thread_reg(&thread1, arena), "thread_reg");
die(mps_thread_reg(&thread2, arena), "thread_reg");
die(mps_root_create_thread(&reg_root, arena, thread1, marker),
"root_create");
die(mps_ap_create(&ap, cl->pool, mps_rank_exact()), "BufferCreate(fooey)");
@ -136,7 +140,8 @@ static void *kid_thread(void *arg)
mps_ap_destroy(ap);
mps_root_destroy(reg_root);
mps_thread_dereg(thread);
mps_thread_dereg(thread2);
mps_thread_dereg(thread1);
return NULL;
}

15
mps/code/apss.c
View file

@ -1,7 +1,7 @@
/* apss.c: AP MANUAL ALLOC STRESS TEST
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*/
@ -77,11 +77,12 @@ static mps_res_t stress(mps_arena_t arena, mps_pool_debug_option_s *options,
/* allocate a load of objects */
for (i=0; i<testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i, align);
res = make((mps_addr_t *)&ps[i], ap, ss[i]);
res = make(&obj, ap, ss[i]);
if (res != MPS_RES_OK)
goto allocFail;
ps[i] = obj;
allocated += ss[i] + debugOverhead;
if (ss[i] >= sizeof(ps[i]))
*ps[i] = 1; /* Write something, so it gets swap. */
@ -121,10 +122,12 @@ static mps_res_t stress(mps_arena_t arena, mps_pool_debug_option_s *options,
}
/* allocate some new objects */
for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i, align);
res = make((mps_addr_t *)&ps[i], ap, ss[i]);
res = make(&obj, ap, ss[i]);
if (res != MPS_RES_OK)
goto allocFail;
ps[i] = obj;
allocated += ss[i] + debugOverhead;
}
check_allocated_size(pool, ap, allocated);
@ -227,7 +230,7 @@ int main(int argc, char *argv[])
testlib_init(argc, argv);
arena_grain_size = rnd_grain(2 * testArenaSIZE);
arena_grain_size = rnd_grain(testArenaSIZE);
MPS_ARGS_BEGIN(args) {
MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, 2 * testArenaSIZE);
MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
@ -259,7 +262,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

31
mps/code/arena.c
View file

@ -43,8 +43,8 @@ static void ArenaTrivCompact(Arena arena, Trace trace);
static void arenaFreePage(Arena arena, Addr base, Pool pool);
static void arenaFreeLandFinish(Arena arena);
static Res ArenaAbsInit(Arena arena, Size grainSize, ArgList args);
static void ArenaAbsFinish(Arena arena);
static Res ArenaAbsDescribe(Arena arena, mps_lib_FILE *stream, Count depth);
static void ArenaAbsFinish(Inst inst);
static Res ArenaAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth);
static void ArenaNoFree(Addr base, Size size, Pool pool)
@ -106,11 +106,12 @@ DEFINE_CLASS(Inst, ArenaClass, klass)
DEFINE_CLASS(Arena, AbstractArena, klass)
{
INHERIT_CLASS(&klass->protocol, AbstractArena, Inst);
INHERIT_CLASS(&klass->instClassStruct, AbstractArena, Inst);
klass->instClassStruct.finish = ArenaAbsFinish;
klass->instClassStruct.describe = ArenaAbsDescribe;
klass->size = sizeof(ArenaStruct);
klass->varargs = ArgTrivVarargs;
klass->init = ArenaAbsInit;
klass->finish = ArenaAbsFinish;
klass->create = ArenaNoCreate;
klass->destroy = ArenaNoDestroy;
klass->purgeSpare = ArenaNoPurgeSpare;
@ -120,7 +121,6 @@ DEFINE_CLASS(Arena, AbstractArena, klass)
klass->chunkInit = ArenaNoChunkInit;
klass->chunkFinish = ArenaNoChunkFinish;
klass->compact = ArenaTrivCompact;
klass->describe = ArenaAbsDescribe;
klass->pagesMarkAllocated = ArenaNoPagesMarkAllocated;
klass->sig = ArenaClassSig;
}
@ -130,11 +130,10 @@ DEFINE_CLASS(Arena, AbstractArena, klass)
Bool ArenaClassCheck(ArenaClass klass)
{
CHECKD(InstClass, &klass->protocol);
CHECKD(InstClass, &klass->instClassStruct);
CHECKL(klass->size >= sizeof(ArenaStruct));
CHECKL(FUNCHECK(klass->varargs));
CHECKL(FUNCHECK(klass->init));
CHECKL(FUNCHECK(klass->finish));
CHECKL(FUNCHECK(klass->create));
CHECKL(FUNCHECK(klass->destroy));
CHECKL(FUNCHECK(klass->purgeSpare));
@ -144,7 +143,6 @@ Bool ArenaClassCheck(ArenaClass klass)
CHECKL(FUNCHECK(klass->chunkInit));
CHECKL(FUNCHECK(klass->chunkFinish));
CHECKL(FUNCHECK(klass->compact));
CHECKL(FUNCHECK(klass->describe));
CHECKL(FUNCHECK(klass->pagesMarkAllocated));
CHECKS(ArenaClass, klass);
return TRUE;
@ -406,19 +404,15 @@ failInit:
}
/* ArenaAbsFinish -- 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.
*/
/* ArenaAbsFinish -- finish the generic part of the arena */
static void ArenaAbsFinish(Arena arena)
static void ArenaAbsFinish(Inst inst)
{
Arena arena = MustBeA(AbstractArena, inst);
AVERC(Arena, arena);
PoolFinish(ArenaCBSBlockPool(arena));
arena->sig = SigInvalid;
InstFinish(MustBeA(Inst, arena));
NextMethod(Inst, AbstractArena, finish)(inst);
GlobalsFinish(ArenaGlobals(arena));
LocusFinish(arena);
RingFinish(ArenaChunkRing(arena));
@ -510,8 +504,9 @@ void ControlFinish(Arena arena)
/* ArenaDescribe -- describe the arena */
static Res ArenaAbsDescribe(Arena arena, mps_lib_FILE *stream, Count depth)
static Res ArenaAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Arena arena = CouldBeA(AbstractArena, inst);
Res res;
if (!TESTC(AbstractArena, arena))
@ -565,7 +560,7 @@ static Res ArenaAbsDescribe(Arena arena, mps_lib_FILE *stream, Count depth)
Res ArenaDescribe(Arena arena, mps_lib_FILE *stream, Count depth)
{
return Method(Arena, arena, describe)(arena, stream, depth);
return Method(Inst, arena, describe)(MustBeA(Inst, arena), stream, depth);
}

4
mps/code/arenacl.c
View file

@ -311,7 +311,7 @@ static Res ClientArenaCreate(Arena *arenaReturn, ArgList args)
return ResOK;
failChunkCreate:
NextMethod(Arena, ClientArena, finish)(arena);
NextMethod(Inst, ClientArena, finish)(MustBeA(Inst, arena));
failSuperInit:
AVER(res != ResOK);
return res;
@ -336,7 +336,7 @@ static void ClientArenaDestroy(Arena arena)
AVER(arena->reserved == 0);
AVER(arena->committed == 0);
NextMethod(Arena, ClientArena, finish)(arena); /* <code/arena.c#finish.caller> */
NextMethod(Inst, ClientArena, finish)(MustBeA(Inst, arena));
}

23
mps/code/arenavm.c
View file

@ -187,17 +187,18 @@ static Bool VMArenaCheck(VMArena vmArena)
/* VMArenaDescribe -- describe the VMArena
*/
static Res VMArenaDescribe(Arena arena, mps_lib_FILE *stream, Count depth)
static Res VMArenaDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Res res;
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(Arena, VMArena, describe)(arena, stream, depth);
res = NextMethod(Inst, VMArena, describe)(inst, stream, depth);
if (res != ResOK)
return res;
@ -502,6 +503,7 @@ static Res vmArenaChunkSize(Size *chunkSizeReturn, VMArena vmArena, Size size)
overhead = 0;
do {
chunkSize = size + overhead;
AVER(SizeIsAligned(chunkSize, grainSize));
/* See .overhead.chunk-struct. */
overhead = SizeAlignUp(sizeof(VMChunkStruct), MPS_PF_ALIGN);
@ -632,15 +634,18 @@ static Res VMArenaCreate(Arena *arenaReturn, ArgList args)
goto failChunkCreate;
#if defined(AVER_AND_CHECK_ALL)
/* Check that the computation of the chunk size in vmArenaChunkSize
* was correct, now that we have the actual chunk for comparison. */
/* 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));
AVER(computedChunkSize == ChunkSize(chunk)
|| computedChunkSize + grainSize == ChunkSize(chunk));
}
#endif
@ -662,7 +667,7 @@ static Res VMArenaCreate(Arena *arenaReturn, ArgList args)
return ResOK;
failChunkCreate:
NextMethod(Arena, VMArena, finish)(arena);
NextMethod(Inst, VMArena, finish)(MustBeA(Inst, arena));
failArenaInit:
VMUnmap(vm, VMBase(vm), VMLimit(vm));
failVMMap:
@ -697,7 +702,7 @@ static void VMArenaDestroy(Arena arena)
vmArena->sig = SigInvalid;
NextMethod(Arena, VMArena, finish)(arena); /* <code/global.c#finish.caller> */
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. */
@ -1191,6 +1196,7 @@ mps_res_t mps_arena_vm_growth(mps_arena_t mps_arena,
DEFINE_CLASS(Arena, VMArena, klass)
{
INHERIT_CLASS(klass, VMArena, AbstractArena);
klass->instClassStruct.describe = VMArenaDescribe;
klass->size = sizeof(VMArenaStruct);
klass->varargs = VMArenaVarargs;
klass->create = VMArenaCreate;
@ -1201,7 +1207,6 @@ DEFINE_CLASS(Arena, VMArena, klass)
klass->chunkInit = VMChunkInit;
klass->chunkFinish = VMChunkFinish;
klass->compact = VMCompact;
klass->describe = VMArenaDescribe;
klass->pagesMarkAllocated = VMPagesMarkAllocated;
}

132
mps/code/buffer.c
View file

@ -1,7 +1,7 @@
/* buffer.c: ALLOCATION BUFFER IMPLEMENTATION
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .purpose: This is (part of) the implementation of allocation buffers.
* Several macros which also form part of the implementation are in
@ -119,54 +119,47 @@ Bool BufferCheck(Buffer buffer)
*
* See <code/mpmst.h> for structure definitions. */
Res BufferDescribe(Buffer buffer, mps_lib_FILE *stream, Count depth)
static Res BufferAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Buffer buffer = CouldBeA(Buffer, inst);
Res res;
BufferClass klass;
if (!TESTC(Buffer, buffer))
return ResPARAM;
if (stream == NULL)
return ResPARAM;
klass = ClassOfPoly(Buffer, buffer);
res = WriteF(stream, depth,
"Buffer $P ($U) {\n",
(WriteFP)buffer, (WriteFU)buffer->serial,
" class $P (\"$S\")\n",
(WriteFP)klass, (WriteFS)ClassName(klass),
" Arena $P\n", (WriteFP)buffer->arena,
" Pool $P\n", (WriteFP)buffer->pool,
" ", buffer->isMutator ? "Mutator" : "Internal", " Buffer\n",
" mode $C$C$C$C (TRANSITION, LOGGED, FLIPPED, ATTACHED)\n",
(WriteFC)((buffer->mode & BufferModeTRANSITION) ? 't' : '_'),
(WriteFC)((buffer->mode & BufferModeLOGGED) ? 'l' : '_'),
(WriteFC)((buffer->mode & BufferModeFLIPPED) ? 'f' : '_'),
(WriteFC)((buffer->mode & BufferModeATTACHED) ? 'a' : '_'),
" fillSize $UKb\n", (WriteFU)(buffer->fillSize / 1024),
" emptySize $UKb\n", (WriteFU)(buffer->emptySize / 1024),
" alignment $W\n", (WriteFW)buffer->alignment,
" base $A\n", (WriteFA)buffer->base,
" initAtFlip $A\n", (WriteFA)buffer->initAtFlip,
" init $A\n", (WriteFA)buffer->ap_s.init,
" alloc $A\n", (WriteFA)buffer->ap_s.alloc,
" limit $A\n", (WriteFA)buffer->ap_s.limit,
" poolLimit $A\n", (WriteFA)buffer->poolLimit,
" alignment $W\n", (WriteFW)buffer->alignment,
" rampCount $U\n", (WriteFU)buffer->rampCount,
NULL);
res = NextMethod(Inst, Buffer, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = Method(Buffer, buffer, describe)(buffer, stream, depth + 2);
if (res != ResOK)
return res;
return WriteF(stream, depth + 2,
"serial $U\n", (WriteFU)buffer->serial,
"Arena $P\n", (WriteFP)buffer->arena,
"Pool $P\n", (WriteFP)buffer->pool,
buffer->isMutator ? "Mutator" : "Internal", " Buffer\n",
"mode $C$C$C$C (TRANSITION, LOGGED, FLIPPED, ATTACHED)\n",
(WriteFC)((buffer->mode & BufferModeTRANSITION) ? 't' : '_'),
(WriteFC)((buffer->mode & BufferModeLOGGED) ? 'l' : '_'),
(WriteFC)((buffer->mode & BufferModeFLIPPED) ? 'f' : '_'),
(WriteFC)((buffer->mode & BufferModeATTACHED) ? 'a' : '_'),
"fillSize $UKb\n", (WriteFU)(buffer->fillSize / 1024),
"emptySize $UKb\n", (WriteFU)(buffer->emptySize / 1024),
"alignment $W\n", (WriteFW)buffer->alignment,
"base $A\n", (WriteFA)buffer->base,
"initAtFlip $A\n", (WriteFA)buffer->initAtFlip,
"init $A\n", (WriteFA)buffer->ap_s.init,
"alloc $A\n", (WriteFA)buffer->ap_s.alloc,
"limit $A\n", (WriteFA)buffer->ap_s.limit,
"poolLimit $A\n", (WriteFA)buffer->poolLimit,
"alignment $W\n", (WriteFW)buffer->alignment,
"rampCount $U\n", (WriteFU)buffer->rampCount,
NULL);
}
res = WriteF(stream, depth, "} Buffer $P ($U)\n",
(WriteFP)buffer, (WriteFU)buffer->serial,
NULL);
return res;
Res BufferDescribe(Buffer buffer, mps_lib_FILE *stream, Count depth)
{
return Method(Inst, buffer, describe)(MustBeA(Inst, buffer), stream, depth);
}
@ -340,8 +333,9 @@ void BufferDestroy(Buffer buffer)
/* BufferFinish -- finish an allocation buffer */
static void BufferAbsFinish(Buffer buffer)
static void BufferAbsFinish(Inst inst)
{
Buffer buffer = MustBeA(Buffer, inst);
AVERT(Buffer, buffer);
AVER(BufferIsReset(buffer));
@ -361,9 +355,9 @@ void BufferFinish(Buffer buffer)
AVERT(Buffer, buffer);
AVER(BufferIsReady(buffer));
BufferDetach(buffer, BufferPool(buffer));
BufferDetach(buffer, BufferPool(buffer)); /* FIXME: Should be in BufferAbsFinish? */
Method(Buffer, buffer, finish)(buffer);
Method(Inst, buffer, finish)(MustBeA(Inst, buffer));
}
@ -493,7 +487,7 @@ Res BufferReserve(Addr *pReturn, Buffer buffer, Size size)
AVERT(Buffer, buffer);
AVER(size > 0);
AVER(SizeIsAligned(size, BufferPool(buffer)->alignment));
AVER(BufferIsReady(buffer));
AVER(BufferIsReady(buffer)); /* <design/check/#.common> */
/* Is there enough room in the unallocated portion of the buffer to */
/* satisfy the request? If so, just increase the alloc marker and */
@ -1006,36 +1000,20 @@ static void bufferNoReassignSeg(Buffer buffer, Seg seg)
}
/* bufferTrivDescribe -- basic Buffer describe method */
static Res bufferTrivDescribe(Buffer buffer, mps_lib_FILE *stream, Count depth)
{
if (!TESTT(Buffer, buffer))
return ResFAIL;
if (stream == NULL)
return ResFAIL;
UNUSED(depth);
/* dispatching function does it all */
return ResOK;
}
/* BufferClassCheck -- check the consistency of a BufferClass */
Bool BufferClassCheck(BufferClass klass)
{
CHECKD(InstClass, &klass->protocol);
CHECKD(InstClass, &klass->instClassStruct);
CHECKL(klass->size >= sizeof(BufferStruct));
CHECKL(FUNCHECK(klass->varargs));
CHECKL(FUNCHECK(klass->init));
CHECKL(FUNCHECK(klass->finish));
CHECKL(FUNCHECK(klass->attach));
CHECKL(FUNCHECK(klass->detach));
CHECKL(FUNCHECK(klass->seg));
CHECKL(FUNCHECK(klass->rankSet));
CHECKL(FUNCHECK(klass->setRankSet));
CHECKL(FUNCHECK(klass->reassignSeg));
CHECKL(FUNCHECK(klass->describe));
CHECKS(BufferClass, klass);
return TRUE;
}
@ -1052,14 +1030,14 @@ DEFINE_CLASS(Inst, BufferClass, klass)
DEFINE_CLASS(Buffer, Buffer, klass)
{
INHERIT_CLASS(&klass->protocol, Buffer, Inst);
INHERIT_CLASS(&klass->instClassStruct, Buffer, Inst);
klass->instClassStruct.finish = BufferAbsFinish;
klass->instClassStruct.describe = BufferAbsDescribe;
klass->size = sizeof(BufferStruct);
klass->varargs = ArgTrivVarargs;
klass->init = BufferAbsInit;
klass->finish = BufferAbsFinish;
klass->attach = bufferTrivAttach;
klass->detach = bufferTrivDetach;
klass->describe = bufferTrivDescribe;
klass->seg = bufferNoSeg;
klass->rankSet = bufferTrivRankSet;
klass->setRankSet = bufferNoSetRankSet;
@ -1130,12 +1108,13 @@ static Res segBufInit(Buffer buffer, Pool pool, Bool isMutator, ArgList args)
/* segBufFinish -- SegBuf finish method */
static void segBufFinish(Buffer buffer)
static void segBufFinish(Inst inst)
{
Buffer buffer = MustBeA(Buffer, inst);
SegBuf segbuf = MustBeA(SegBuf, buffer);
AVER(BufferIsReset(buffer));
segbuf->sig = SigInvalid;
NextMethod(Buffer, SegBuf, finish)(buffer);
NextMethod(Inst, SegBuf, finish)(inst);
}
@ -1157,7 +1136,7 @@ static void segBufAttach(Buffer buffer, Addr base, Addr limit,
found = SegOfAddr(&seg, arena, base);
AVER(found);
AVER(segbuf->seg == NULL);
AVER(SegBuffer(seg) == NULL);
AVER(!SegHasBuffer(seg));
AVER(SegBase(seg) <= base);
AVER(limit <= SegLimit(seg));
@ -1174,11 +1153,8 @@ static void segBufAttach(Buffer buffer, Addr base, Addr limit,
static void segBufDetach(Buffer buffer)
{
SegBuf segbuf = MustBeA(SegBuf, buffer);
Seg seg;
seg = segbuf->seg;
AVER(seg != NULL);
SegSetBuffer(seg, NULL);
Seg seg = segbuf->seg;
SegUnsetBuffer(seg);
segbuf->seg = NULL;
}
@ -1232,8 +1208,9 @@ static void segBufReassignSeg(Buffer buffer, Seg seg)
/* segBufDescribe -- describe method for SegBuf */
static Res segBufDescribe(Buffer buffer, mps_lib_FILE *stream, Count depth)
static Res segBufDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Buffer buffer = CouldBeA(Buffer, inst);
SegBuf segbuf = CouldBeA(SegBuf, buffer);
Res res;
@ -1242,15 +1219,14 @@ static Res segBufDescribe(Buffer buffer, mps_lib_FILE *stream, Count depth)
if (stream == NULL)
return ResPARAM;
/* Describe the superclass fields first via next-method call */
res = NextMethod(Buffer, SegBuf, describe)(buffer, stream, depth);
res = NextMethod(Inst, SegBuf, describe)(inst, stream, depth);
if (res != ResOK)
return res;
return WriteF(stream, depth + 2,
"Seg $P\n", (WriteFP)segbuf->seg,
"rankSet $U\n", (WriteFU)segbuf->rankSet,
NULL);
"Seg $P\n", (WriteFP)segbuf->seg,
"rankSet $U\n", (WriteFU)segbuf->rankSet,
NULL);
}
@ -1262,12 +1238,12 @@ static Res segBufDescribe(Buffer buffer, mps_lib_FILE *stream, Count depth)
DEFINE_CLASS(Buffer, SegBuf, klass)
{
INHERIT_CLASS(klass, SegBuf, Buffer);
klass->instClassStruct.finish = segBufFinish;
klass->instClassStruct.describe = segBufDescribe;
klass->size = sizeof(SegBufStruct);
klass->init = segBufInit;
klass->finish = segBufFinish;
klass->attach = segBufAttach;
klass->detach = segBufDetach;
klass->describe = segBufDescribe;
klass->seg = segBufSeg;
klass->rankSet = segBufRankSet;
klass->setRankSet = segBufSetRankSet;
@ -1333,7 +1309,7 @@ DEFINE_CLASS(Buffer, RankBuf, klass)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

33
mps/code/cbs.c
View file

@ -1,7 +1,7 @@
/* cbs.c: COALESCING BLOCK STRUCTURE IMPLEMENTATION
*
* $Id$
* Copyright (c) 2001-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .intro: This is a portable implementation of coalescing block
* structures.
@ -289,8 +289,9 @@ static Res cbsInitZoned(Land land, Arena arena, Align alignment, ArgList args)
* See <design/land/#function.finish>.
*/
static void cbsFinish(Land land)
static void cbsFinish(Inst inst)
{
Land land = MustBeA(Land, inst);
CBS cbs = MustBeA(CBS, land);
METER_EMIT(&cbs->treeSearch);
@ -301,7 +302,7 @@ static void cbsFinish(Land land)
if (cbs->ownPool)
PoolDestroy(cbsBlockPool(cbs));
NextMethod(Land, CBS, finish)(land);
NextMethod(Inst, CBS, finish)(inst);
}
@ -441,6 +442,9 @@ static void cbsBlockInsert(CBS cbs, CBSBlock block)
*
* .insert.alloc: Will only allocate a block if the range does not
* abut an existing range.
*
* .insert.critical: In manual-allocation-bound programs using MVFF
* this is on the critical path.
*/
static Res cbsInsert(Range rangeReturn, Land land, Range range)
@ -454,9 +458,9 @@ static Res cbsInsert(Range rangeReturn, Land land, Range range)
Bool leftMerge, rightMerge;
Size oldSize;
AVER(rangeReturn != NULL);
AVERT(Range, range);
AVER(RangeIsAligned(range, LandAlignment(land)));
AVER_CRITICAL(rangeReturn != NULL);
AVERT_CRITICAL(Range, range);
AVER_CRITICAL(RangeIsAligned(range, LandAlignment(land)));
base = RangeBase(range);
limit = RangeLimit(range);
@ -526,14 +530,14 @@ static Res cbsInsert(Range rangeReturn, Land land, Range range)
cbsBlockInsert(cbs, block);
}
AVER(newBase <= base);
AVER(newLimit >= limit);
AVER_CRITICAL(newBase <= base);
AVER_CRITICAL(newLimit >= limit);
RangeInit(rangeReturn, newBase, newLimit);
return ResOK;
fail:
AVER(res != ResOK);
AVER_CRITICAL(res != ResOK);
return res;
}
@ -1089,8 +1093,9 @@ fail:
* See <design/land/#function.describe>.
*/
static Res cbsDescribe(Land land, mps_lib_FILE *stream, Count depth)
static Res cbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Land land = CouldBeA(Land, inst);
CBS cbs = CouldBeA(CBS, land);
Res res;
Res (*describe)(Tree, mps_lib_FILE *);
@ -1100,7 +1105,7 @@ static Res cbsDescribe(Land land, mps_lib_FILE *stream, Count depth)
if (stream == NULL)
return ResPARAM;
res = NextMethod(Land, CBS, describe)(land, stream, depth);
res = NextMethod(Inst, CBS, describe)(inst, stream, depth);
if (res != ResOK)
return res;
@ -1133,9 +1138,10 @@ static Res cbsDescribe(Land land, mps_lib_FILE *stream, Count depth)
DEFINE_CLASS(Land, CBS, klass)
{
INHERIT_CLASS(klass, CBS, Land);
klass->instClassStruct.describe = cbsDescribe;
klass->instClassStruct.finish = cbsFinish;
klass->size = sizeof(CBSStruct);
klass->init = cbsInit;
klass->finish = cbsFinish;
klass->sizeMethod = cbsSize;
klass->insert = cbsInsert;
klass->delete = cbsDelete;
@ -1145,7 +1151,6 @@ DEFINE_CLASS(Land, CBS, klass)
klass->findLast = cbsFindLast;
klass->findLargest = cbsFindLargest;
klass->findInZones = cbsFindInZones;
klass->describe = cbsDescribe;
}
DEFINE_CLASS(Land, CBSFast, klass)
@ -1163,7 +1168,7 @@ DEFINE_CLASS(Land, CBSZoned, klass)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

16
mps/code/comm.gmk
View file

@ -73,9 +73,9 @@ endif
# EXTRA TARGETS
#
# Don't build mpseventsql by default (might not have sqlite3 installed),
# but do build mpseventcnv and mpseventtxt.
# but do build mpseventcnv, mpseventpy and mpseventtxt.
EXTRA_TARGETS ?= mpseventcnv mpseventtxt
EXTRA_TARGETS ?= mpseventcnv mpseventpy mpseventtxt
#
@ -332,8 +332,7 @@ RATIO=$$(awk "BEGIN{print int(100 * $$TIME_HOT / $$TIME_RASH)}"); \
printf "Performance ratio (hot/rash) for $(2): %d%%\n" $$RATIO
endef
.PHONY: testratio
testratio:
testratio: phony
$(MAKE) -f $(PFM).gmk VARIETY=hot djbench gcbench
$(MAKE) -f $(PFM).gmk VARIETY=rash djbench gcbench
$(call ratio,gcbench,amc)
@ -354,6 +353,12 @@ $(PFM)/$(VARIETY)/testmmqa:
(cd ../test && $(MMQA) runset testsets/passing)
# == Toy Scheme interpreter ==
testscheme: phony
$(MAKE) -C ../example/scheme test
# These convenience targets allow one to type "make foo" to build target
# foo in selected varieties (or none, for the latter rule).
@ -572,6 +577,9 @@ $(PFM)/$(VARIETY)/zmess: $(PFM)/$(VARIETY)/zmess.o \
$(PFM)/$(VARIETY)/mpseventcnv: $(PFM)/$(VARIETY)/eventcnv.o \
$(PFM)/$(VARIETY)/mps.a
$(PFM)/$(VARIETY)/mpseventpy: $(PFM)/$(VARIETY)/eventpy.o \
$(PFM)/$(VARIETY)/mps.a
$(PFM)/$(VARIETY)/mpseventtxt: $(PFM)/$(VARIETY)/eventtxt.o \
$(PFM)/$(VARIETY)/mps.a

10
mps/code/commpost.nmk
View file

@ -1,7 +1,7 @@
# commpost.nmk: SECOND COMMON FRAGMENT FOR PLATFORMS USING NMAKE -*- makefile -*-
#
# $Id$
# Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
# Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
#
# DESCRIPTION
#
@ -315,6 +315,9 @@ $(PFM)\$(VARIETY)\ztfm.exe: $(PFM)\$(VARIETY)\ztfm.obj \
$(PFM)\$(VARIETY)\mpseventcnv.exe: $(PFM)\$(VARIETY)\eventcnv.obj \
$(PFM)\$(VARIETY)\mps.lib
$(PFM)\$(VARIETY)\mpseventpy.exe: $(PFM)\$(VARIETY)\eventpy.obj \
$(PFM)\$(VARIETY)\mps.lib
$(PFM)\$(VARIETY)\mpseventtxt.exe: $(PFM)\$(VARIETY)\eventtxt.obj \
$(PFM)\$(VARIETY)\mps.lib
@ -335,6 +338,9 @@ $(PFM)\$(VARIETY)\replaysw.obj: $(PFM)\$(VARIETY)\replay.obj
$(PFM)\$(VARIETY)\mpseventcnv.obj: $(PFM)\$(VARIETY)\eventcnv.obj
copy $** $@ >nul:
$(PFM)\$(VARIETY)\mpseventpy.obj: $(PFM)\$(VARIETY)\eventpy.obj
copy $** $@ >nul:
$(PFM)\$(VARIETY)\mpseventtxt.obj: $(PFM)\$(VARIETY)\eventtxt.obj
copy $** $@ >nul:
@ -385,7 +391,7 @@ $(PFM)\$(VARIETY)\sqlite3.obj:
# C. COPYRIGHT AND LICENSE
#
# Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
# 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.
#

2
mps/code/commpre.nmk
View file

@ -105,7 +105,7 @@ TEST_TARGETS=\
# Stand-alone programs go in EXTRA_TARGETS if they should always be
# built, or in OPTIONAL_TARGETS if they should only be built if
EXTRA_TARGETS=mpseventcnv.exe mpseventtxt.exe
EXTRA_TARGETS=mpseventcnv.exe mpseventpy.exe mpseventtxt.exe
OPTIONAL_TARGETS=mpseventsql.exe
# This target records programs that we were once able to build but

23
mps/code/config.h
View file

@ -610,6 +610,29 @@
#endif
/* POSIX thread extensions configuration -- see <code/pthrdext.c> */
#if defined(MPS_OS_LI) || defined(MPS_OS_FR)
/* PTHREADEXT_SIGSUSPEND -- signal used to suspend a thread
* See <design/pthreadext/#impl.signals>
*/
#if defined(CONFIG_PTHREADEXT_SIGSUSPEND)
#define PTHREADEXT_SIGSUSPEND CONFIG_PTHREADEXT_SIGSUSPEND
#else
#define PTHREADEXT_SIGSUSPEND SIGXFSZ
#endif
/* PTHREADEXT_SIGRESUME -- signal used to resume a thread
* See <design/pthreadext/#impl.signals>
*/
#if defined(CONFIG_PTHREADEXT_SIGRESUME)
#define PTHREADEXT_SIGRESUME CONFIG_PTHREADEXT_SIGRESUME
#else
#define PTHREADEXT_SIGRESUME SIGXCPU
#endif
#endif
/* Tracer Configuration -- see <code/trace.c> */

17
mps/code/dbgpool.c
View file

@ -1,7 +1,7 @@
/* dbgpool.c: POOL DEBUG MIXIN
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*
* .source: design.mps.object-debug
@ -206,7 +206,7 @@ static Res DebugPoolInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
return ResOK;
tagFail:
SuperclassPoly(Pool, klass)->finish(pool);
SuperclassPoly(Inst, klass)->finish(MustBeA(Inst, pool));
AVER(res != ResOK);
return res;
}
@ -214,8 +214,9 @@ tagFail:
/* DebugPoolFinish -- finish method for a debug pool */
static void DebugPoolFinish(Pool pool)
static void DebugPoolFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
PoolDebugMixin debug;
PoolClass klass;
@ -229,7 +230,7 @@ static void DebugPoolFinish(Pool pool)
PoolDestroy(debug->tagPool);
}
klass = ClassOfPoly(Pool, pool);
SuperclassPoly(Pool, klass)->finish(pool);
SuperclassPoly(Inst, klass)->finish(inst);
}
@ -523,7 +524,7 @@ static void fenceFree(PoolDebugMixin debug,
{
Size alignedFenceSize, alignedSize;
ASSERT(fenceCheck(debug, pool, old, size), "fencepost check on free");
ASSERT(fenceCheck(debug, pool, old, size), "fencepost check on free"); /* <design/check/#.common> */
alignedFenceSize = SizeAlignUp(debug->fenceSize, PoolAlignment(pool));
alignedSize = SizeAlignUp(size, PoolAlignment(pool));
@ -738,7 +739,7 @@ void DebugPoolFreeCheck(Pool pool, Addr base, Addr limit)
AVERT(PoolDebugMixin, debug);
if (debug->freeSize != 0)
ASSERT(freeCheck(debug, pool, base, limit),
"free space corrupted on release");
"free space corrupted on release"); /* <design/check/#.common> */
}
}
@ -775,8 +776,8 @@ void DebugPoolCheckFreeSpace(Pool pool)
void PoolClassMixInDebug(PoolClass klass)
{
/* Can't check klass because it's not initialized yet */
klass->instClassStruct.finish = DebugPoolFinish;
klass->init = DebugPoolInit;
klass->finish = DebugPoolFinish;
klass->alloc = DebugPoolAlloc;
klass->free = DebugPoolFree;
}
@ -784,7 +785,7 @@ void PoolClassMixInDebug(PoolClass klass)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

12
mps/code/event.c
View file

@ -205,17 +205,17 @@ void EventInit(void)
if (!eventInited) {
EventKind kind;
for (kind = 0; kind < EventKindLIMIT; ++kind) {
AVER(EventLast[kind] == NULL);
AVER(EventWritten[kind] == NULL);
EventLast[kind] = EventWritten[kind] = EventBuffer[kind] + EventBufferSIZE;
AVER(EventLast[kind] == NULL);
AVER(EventWritten[kind] == NULL);
EventLast[kind] = EventWritten[kind] = EventBuffer[kind] + EventBufferSIZE;
}
eventInited = TRUE;
EventKindControl = (Word)mps_lib_telemetry_control();
EventInternSerial = (Serial)1; /* 0 is reserved */
(void)EventInternString(MPSVersion()); /* emit version */
EVENT7(EventInit, EVENT_VERSION_MAJOR, EVENT_VERSION_MEDIAN,
EVENT_VERSION_MINOR, EventCodeMAX, EventNameMAX, MPS_WORD_WIDTH,
mps_clocks_per_sec());
EVENT_VERSION_MINOR, EventCodeMAX, EventNameMAX, MPS_WORD_WIDTH,
mps_clocks_per_sec());
/* flush these initial events to get the first ClockSync out. */
EventSync();
}
@ -520,7 +520,7 @@ extern void EventDump(mps_lib_FILE *stream)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

103
mps/code/eventpy.c Normal file
View file

@ -0,0 +1,103 @@
/* eventpy.c: GENERATE PYTHON INTERFACE TO EVENTS
*
* $Id$
* Copyright (c) 2016 Ravenbrook Limited. See end of file for license.
*
* This command-line program emits Python data structures that can be
* used to parse an event stream in text format (as output by the
* mpseventcnv program).
*/
#include <stdio.h> /* printf, puts */
#include "event.h"
int main(int argc, char *argv[])
{
UNUSED(argc);
UNUSED(argv);
puts("from collections import namedtuple");
printf("__version__ = %d, %d, %d\n", EVENT_VERSION_MAJOR,
EVENT_VERSION_MEDIAN, EVENT_VERSION_MINOR);
puts("EventKind = namedtuple('EventKind', 'name code doc')");
puts("class kind:");
#define ENUM(_, NAME, DOC) \
printf(" " #NAME " = EventKind('" #NAME "', %d, \"%s\")\n", \
EventKind ## NAME, DOC);
EventKindENUM(ENUM, _);
#undef ENUM
puts("kinds = {");
#define ENUM(_, NAME, _1) \
printf(" %d: kind." #NAME ",\n", EventKind ## NAME);
EventKindENUM(ENUM, _);
#undef ENUM
puts("}");
puts("EventParam = namedtuple('EventParam', 'sort, name')");
puts("Event = namedtuple('Event', 'name code always kind params')");
puts("class event:");
#define EVENT_PARAM(X, INDEX, SORT, NAME) \
puts(" EventParam('" #SORT "', '" #NAME "'),");
#define EVENT_DEFINE(X, NAME, CODE, ALWAYS, KIND) \
printf(" " #NAME " = Event('" #NAME "', %d, %s, kind." #KIND ", [\n", \
CODE, ALWAYS ? "True" : "False"); \
EVENT_ ## NAME ## _PARAMS(EVENT_PARAM, X); \
puts(" ]);");
EVENT_LIST(EVENT_DEFINE, 0);
#undef EVENT
puts("events = {");
#define EVENT_ITEM(X, NAME, CODE, ALWAYS, KIND) \
printf(" %d: event." #NAME ",\n", CODE);
EVENT_LIST(EVENT_ITEM, 0);
#undef EVENT
puts("}");
return 0;
}
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 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.
*/

14
mps/code/failover.c
View file

@ -52,11 +52,12 @@ static Res failoverInit(Land land, Arena arena, Align alignment, ArgList args)
}
static void failoverFinish(Land land)
static void failoverFinish(Inst inst)
{
Land land = MustBeA(Land, inst);
Failover fo = MustBeA(Failover, land);
fo->sig = SigInvalid;
NextMethod(Land, Failover, finish)(land);
NextMethod(Inst, Failover, finish)(inst);
}
@ -240,8 +241,9 @@ static Bool failoverFindInZones(Bool *foundReturn, Range rangeReturn, Range oldR
}
static Res failoverDescribe(Land land, mps_lib_FILE *stream, Count depth)
static Res failoverDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Land land = CouldBeA(Land, inst);
Failover fo = CouldBeA(Failover, land);
LandClass primaryClass, secondaryClass;
Res res;
@ -251,7 +253,7 @@ static Res failoverDescribe(Land land, mps_lib_FILE *stream, Count depth)
if (stream == NULL)
return ResPARAM;
res = NextMethod(Land, Failover, describe)(land, stream, depth);
res = NextMethod(Inst, Failover, describe)(inst, stream, depth);
if (res != ResOK)
return res;
@ -272,9 +274,10 @@ static Res failoverDescribe(Land land, mps_lib_FILE *stream, Count depth)
DEFINE_CLASS(Land, Failover, klass)
{
INHERIT_CLASS(klass, Failover, Land);
klass->instClassStruct.describe = failoverDescribe;
klass->instClassStruct.finish = failoverFinish;
klass->size = sizeof(FailoverStruct);
klass->init = failoverInit;
klass->finish = failoverFinish;
klass->sizeMethod = failoverSize;
klass->insert = failoverInsert;
klass->delete = failoverDelete;
@ -283,7 +286,6 @@ DEFINE_CLASS(Land, Failover, klass)
klass->findLast = failoverFindLast;
klass->findLargest = failoverFindLargest;
klass->findInZones = failoverFindInZones;
klass->describe = failoverDescribe;
}

6
mps/code/format.c
View file

@ -1,7 +1,7 @@
/* format.c: OBJECT FORMATS
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (c) 2002 Global Graphics Software.
*
* DESIGN
@ -168,7 +168,7 @@ Res FormatCreate(Format *formatReturn, Arena arena, ArgList args)
void FormatDestroy(Format format)
{
AVERT(Format, format);
AVER(format->poolCount == 0);
AVER(format->poolCount == 0); /* <design/check/#.common> */
RingRemove(&format->arenaRing);
@ -250,7 +250,7 @@ Res FormatDescribe(Format format, mps_lib_FILE *stream, Count depth)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

102
mps/code/fotest.c
View file

@ -1,7 +1,7 @@
/* fotest.c: FAIL-OVER TEST
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*
* This tests fail-over behaviour in low memory situations. The MVFF
@ -10,9 +10,8 @@
* request due to running out of memory, they fall back to a Freelist
* (which has zero memory overhead, at some cost in performance).
*
* This is a white box test: it patches the class of the CBS's
* internal block pool (MFS) with a pointer to a dummy class whose
* alloc() method always returns ResMEMORY.
* This is a white box test: it monkey-patches the MFS pool's alloc
* method with a method that always returns a memory error code.
*/
@ -36,40 +35,6 @@
#define testLOOPS 10
/* Accessors for the CBS used to implement a pool. */
extern Land _mps_mvff_cbs(Pool);
extern Land _mps_mvt_cbs(Pool);
/* "OOM" pool class -- dummy alloc/free pool class whose alloc()
* method always fails and whose free method does nothing. */
static Res oomAlloc(Addr *pReturn, Pool pool, Size size)
{
UNUSED(pReturn);
UNUSED(pool);
UNUSED(size);
switch (rnd() % 3) {
case 0:
return ResRESOURCE;
case 1:
return ResMEMORY;
default:
return ResCOMMIT_LIMIT;
}
}
DECLARE_CLASS(Pool, OOMPool, AbstractPool);
DEFINE_CLASS(Pool, OOMPool, klass)
{
INHERIT_CLASS(klass, OOMPool, AbstractPool);
klass->alloc = oomAlloc;
klass->free = PoolTrivFree;
klass->size = sizeof(PoolStruct);
}
/* make -- allocate one object */
static mps_res_t make(mps_addr_t *p, mps_ap_t ap, size_t size)
@ -86,19 +51,44 @@ static mps_res_t make(mps_addr_t *p, mps_ap_t ap, size_t size)
}
/* set_oom -- set blockPool of CBS to OOM or MFS according to argument. */
/* The original alloc method on the MFS pool. */
static PoolAllocMethod mfs_alloc;
static void set_oom(Land land, int oom)
/* oomAlloc -- allocation function that always fails
*
* Returns a randomly chosen memory error code.
*/
static Res oomAlloc(Addr *pReturn, Pool pool, Size size)
{
CBS cbs = MustBeA(CBS, land);
SetClassOfPoly(cbs->blockPool, oom ? CLASS(OOMPool) : PoolClassMFS());
MFS mfs = MustBeA(MFSPool, pool);
UNUSED(pReturn);
UNUSED(size);
if (mfs->extendSelf) {
/* This is the MFS block pool belonging to the CBS belonging to
* the MVFF or MVT pool under test, so simulate a failure to
* enforce the fail-over behaviour. */
switch (rnd() % 3) {
case 0:
return ResRESOURCE;
case 1:
return ResMEMORY;
default:
return ResCOMMIT_LIMIT;
}
} else {
/* This is the MFS block pool belonging to the arena's free land,
* so succeed here (see job004041). */
return mfs_alloc(pReturn, pool, size);
}
}
/* stress -- create an allocation point and allocate in it */
static mps_res_t stress(size_t (*size)(unsigned long, mps_align_t),
mps_align_t alignment, mps_pool_t pool, Land cbs)
mps_align_t alignment, mps_pool_t pool)
{
mps_res_t res = MPS_RES_OK;
mps_ap_t ap;
@ -110,11 +100,12 @@ static mps_res_t stress(size_t (*size)(unsigned long, mps_align_t),
/* allocate a load of objects */
for (i=0; i<testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i, alignment);
res = make((mps_addr_t *)&ps[i], ap, ss[i]);
res = make(&obj, ap, ss[i]);
if (res != MPS_RES_OK)
goto allocFail;
ps[i] = obj;
if (ss[i] >= sizeof(ps[i]))
*ps[i] = 1; /* Write something, so it gets swap. */
}
@ -140,15 +131,17 @@ static mps_res_t stress(size_t (*size)(unsigned long, mps_align_t),
}
/* allocate some new objects */
for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i, alignment);
res = make((mps_addr_t *)&ps[i], ap, ss[i]);
res = make(&obj, ap, ss[i]);
if (res != MPS_RES_OK)
goto allocFail;
ps[i] = obj;
}
set_oom(cbs, rnd() % 2);
CLASS_STATIC(MFSPool).alloc = rnd() % 2 ? mfs_alloc : oomAlloc;
}
set_oom(cbs, 0);
CLASS_STATIC(MFSPool).alloc = mfs_alloc;
allocFail:
mps_ap_destroy(ap);
@ -177,6 +170,7 @@ int main(int argc, char *argv[])
die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
"mps_arena_create");
mfs_alloc = CLASS_STATIC(MFSPool).alloc;
alignment = sizeof(void *) << (rnd() % 4);
MPS_ARGS_BEGIN(args) {
MPS_ARGS_ADD(args, MPS_KEY_EXTEND_BY, (64 + rnd() % 64) * 1024);
@ -187,10 +181,7 @@ int main(int argc, char *argv[])
MPS_ARGS_ADD(args, MPS_KEY_MVFF_FIRST_FIT, rnd() % 2);
die(mps_pool_create_k(&pool, arena, mps_class_mvff(), args), "create MVFF");
} MPS_ARGS_END(args);
{
die(stress(randomSizeAligned, alignment, pool, _mps_mvff_cbs(pool)),
"stress MVFF");
}
die(stress(randomSizeAligned, alignment, pool), "stress MVFF");
mps_pool_destroy(pool);
mps_arena_destroy(arena);
@ -206,10 +197,7 @@ int main(int argc, char *argv[])
MPS_ARGS_ADD(args, MPS_KEY_MVT_FRAG_LIMIT, (rnd() % 101) / 100.0);
die(mps_pool_create_k(&pool, arena, mps_class_mvt(), args), "create MVFF");
} MPS_ARGS_END(args);
{
die(stress(randomSizeAligned, alignment, pool, _mps_mvt_cbs(pool)),
"stress MVT");
}
die(stress(randomSizeAligned, alignment, pool), "stress MVT");
mps_pool_destroy(pool);
mps_arena_destroy(arena);
@ -220,7 +208,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

14
mps/code/freelist.c
View file

@ -212,12 +212,13 @@ static Res freelistInit(Land land, Arena arena, Align alignment, ArgList args)
}
static void freelistFinish(Land land)
static void freelistFinish(Inst inst)
{
Land land = MustBeA(Land, inst);
Freelist fl = MustBeA(Freelist, land);
fl->sig = SigInvalid;
fl->list = freelistEND;
NextMethod(Land, Freelist, finish)(land);
NextMethod(Inst, Freelist, finish)(inst);
}
@ -745,8 +746,9 @@ static Bool freelistDescribeVisitor(Land land, Range range,
}
static Res freelistDescribe(Land land, mps_lib_FILE *stream, Count depth)
static Res freelistDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Land land = CouldBeA(Land, inst);
Freelist fl = CouldBeA(Freelist, land);
Res res;
Bool b;
@ -757,7 +759,7 @@ static Res freelistDescribe(Land land, mps_lib_FILE *stream, Count depth)
if (stream == NULL)
return ResPARAM;
res = NextMethod(Land, Freelist, describe)(land, stream, depth);
res = NextMethod(Inst, Freelist, describe)(inst, stream, depth);
if (res != ResOK)
return res;
@ -779,9 +781,10 @@ static Res freelistDescribe(Land land, mps_lib_FILE *stream, Count depth)
DEFINE_CLASS(Land, Freelist, klass)
{
INHERIT_CLASS(klass, Freelist, Land);
klass->instClassStruct.describe = freelistDescribe;
klass->instClassStruct.finish = freelistFinish;
klass->size = sizeof(FreelistStruct);
klass->init = freelistInit;
klass->finish = freelistFinish;
klass->sizeMethod = freelistSize;
klass->insert = freelistInsert;
klass->delete = freelistDelete;
@ -791,7 +794,6 @@ DEFINE_CLASS(Land, Freelist, klass)
klass->findLast = freelistFindLast;
klass->findLargest = freelistFindLargest;
klass->findInZones = freelistFindInZones;
klass->describe = freelistDescribe;
}

17
mps/code/global.c
View file

@ -1,7 +1,7 @@
/* global.c: ARENA-GLOBAL INTERFACES
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*
* .sources: See <design/arena/>. design.mps.thread-safety is relevant
@ -188,7 +188,8 @@ Bool GlobalsCheck(Globals arenaGlobals)
CHECKL(RingCheck(&arenaRing));
CHECKL(BoolCheck(arena->emergency));
/* There can only be an emergency when a trace is busy. */
/* .emergency.invariant: There can only be an emergency when a trace
* is busy. */
CHECKL(!arena->emergency || arena->busyTraces != TraceSetEMPTY);
if (arenaGlobals->defaultChain != NULL)
@ -463,12 +464,12 @@ void GlobalsPrepareToDestroy(Globals arenaGlobals)
* and so RingCheck dereferences a pointer into that unmapped memory
* and we get a crash instead of an assertion. See job000652.
*/
AVER(RingIsSingle(&arena->formatRing));
AVER(RingIsSingle(&arena->chainRing));
AVER(RingIsSingle(&arena->formatRing)); /* <design/check/#.common> */
AVER(RingIsSingle(&arena->chainRing)); /* <design/check/#.common> */
AVER(RingIsSingle(&arena->messageRing));
AVER(RingIsSingle(&arena->threadRing));
AVER(RingIsSingle(&arena->threadRing)); /* <design/check/#.common> */
AVER(RingIsSingle(&arena->deadRing));
AVER(RingIsSingle(&arenaGlobals->rootRing));
AVER(RingIsSingle(&arenaGlobals->rootRing)); /* <design/check/#.common> */
for(rank = RankMIN; rank < RankLIMIT; ++rank)
AVER(RingIsSingle(&arena->greyRing[rank]));
@ -478,7 +479,7 @@ void GlobalsPrepareToDestroy(Globals arenaGlobals)
* 2. arena->controlPoolStruct.blockPoolStruct
* 3. arena->controlPoolStruct.spanPoolStruct
*/
AVER(RingLength(&arenaGlobals->poolRing) == 4);
AVER(RingLength(&arenaGlobals->poolRing) == 4); /* <design/check/#.common> */
}
@ -1066,7 +1067,7 @@ Bool ArenaEmergency(Arena arena)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

64
mps/code/land.c
View file

@ -1,7 +1,7 @@
/* land.c: LAND (COLLECTION OF ADDRESS RANGES) IMPLEMENTATION
*
* $Id$
* Copyright (c) 2014-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2014-2016 Ravenbrook Limited. See end of file for license.
*
* .design: <design/land/>
*/
@ -90,11 +90,12 @@ static Res LandAbsInit(Land land, Arena arena, Align alignment, ArgList args)
return ResOK;
}
static void LandAbsFinish(Land land)
static void LandAbsFinish(Inst inst)
{
Land land = MustBeA(Land, inst);
AVERC(Land, land);
land->sig = SigInvalid;
InstFinish(CouldBeA(Inst, land));
NextMethod(Inst, Land, finish)(inst);
}
@ -183,19 +184,22 @@ void LandFinish(Land land)
AVERC(Land, land);
landEnter(land);
Method(Land, land, finish)(land);
Method(Inst, land, finish)(MustBeA(Inst, land));
}
/* LandSize -- return the total size of ranges in land
*
* See <design/land/#function.size>
*
* .size.critical: In manual-allocation-bound programs using MVFF this
* is on the critical path.
*/
Size LandSize(Land land)
{
/* .enter-leave.simple */
AVERC(Land, land);
AVERC_CRITICAL(Land, land);
return Method(Land, land, sizeMethod)(land);
}
@ -204,17 +208,20 @@ Size LandSize(Land land)
/* LandInsert -- insert range of addresses into land
*
* See <design/land/#function.insert>
*
* .insert.critical: In manual-allocation-bound programs using MVFF
* this is on the critical path.
*/
Res LandInsert(Range rangeReturn, Land land, Range range)
{
Res res;
AVER(rangeReturn != NULL);
AVERC(Land, land);
AVERT(Range, range);
AVER(RangeIsAligned(range, land->alignment));
AVER(!RangeIsEmpty(range));
AVER_CRITICAL(rangeReturn != NULL);
AVERC_CRITICAL(Land, land);
AVERT_CRITICAL(Range, range);
AVER_CRITICAL(RangeIsAligned(range, land->alignment));
AVER_CRITICAL(!RangeIsEmpty(range));
landEnter(land);
res = Method(Land, land, insert)(rangeReturn, land, range);
@ -249,13 +256,16 @@ Res LandDelete(Range rangeReturn, Land land, Range range)
/* LandIterate -- iterate over isolated ranges of addresses in land
*
* See <design/land/#function.iterate>
*
* .iterate.critical: In manual-allocation-bound programs using MVFF
* this is on the critical path.
*/
Bool LandIterate(Land land, LandVisitor visitor, void *closure)
{
Bool b;
AVERC(Land, land);
AVER(FUNCHECK(visitor));
AVERC_CRITICAL(Land, land);
AVER_CRITICAL(FUNCHECK(visitor));
landEnter(land);
b = Method(Land, land, iterate)(land, visitor, closure);
@ -274,8 +284,8 @@ Bool LandIterate(Land land, LandVisitor visitor, void *closure)
Bool LandIterateAndDelete(Land land, LandDeleteVisitor visitor, void *closure)
{
Bool b;
AVERC(Land, land);
AVER(FUNCHECK(visitor));
AVERC_CRITICAL(Land, land);
AVER_CRITICAL(FUNCHECK(visitor));
landEnter(land);
b = Method(Land, land, iterateAndDelete)(land, visitor, closure);
@ -390,7 +400,7 @@ Res LandFindInZones(Bool *foundReturn, Range rangeReturn, Range oldRangeReturn,
Res LandDescribe(Land land, mps_lib_FILE *stream, Count depth)
{
return Method(Land, land, describe)(land, stream, depth);
return Method(Inst, land, describe)(MustBeA(Inst, land), stream, depth);
}
@ -426,12 +436,15 @@ static Bool landFlushVisitor(Bool *deleteReturn, Land land, Range range,
/* LandFlush -- move ranges from src to dest
*
* See <design/land/#function.flush>
*
* .flush.critical: In manual-allocation-bound programs using MVFF
* this is on the critical path.
*/
Bool LandFlush(Land dest, Land src)
{
AVERC(Land, dest);
AVERC(Land, src);
AVERC_CRITICAL(Land, dest);
AVERC_CRITICAL(Land, src);
return LandIterateAndDelete(src, landFlushVisitor, dest);
}
@ -441,17 +454,15 @@ Bool LandFlush(Land dest, Land src)
Bool LandClassCheck(LandClass klass)
{
CHECKL(InstClassCheck(&klass->protocol));
CHECKL(InstClassCheck(&klass->instClassStruct));
CHECKL(klass->size >= sizeof(LandStruct));
CHECKL(FUNCHECK(klass->init));
CHECKL(FUNCHECK(klass->finish));
CHECKL(FUNCHECK(klass->insert));
CHECKL(FUNCHECK(klass->delete));
CHECKL(FUNCHECK(klass->findFirst));
CHECKL(FUNCHECK(klass->findLast));
CHECKL(FUNCHECK(klass->findLargest));
CHECKL(FUNCHECK(klass->findInZones));
CHECKL(FUNCHECK(klass->describe));
CHECKS(LandClass, klass);
return TRUE;
}
@ -543,8 +554,9 @@ static Res landNoFindInZones(Bool *foundReturn, Range rangeReturn, Range oldRang
return ResUNIMPL;
}
static Res LandAbsDescribe(Land land, mps_lib_FILE *stream, Count depth)
static Res LandAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Land land = CouldBeA(Land, inst);
LandClass klass;
Res res;
@ -553,7 +565,7 @@ static Res LandAbsDescribe(Land land, mps_lib_FILE *stream, Count depth)
if (stream == NULL)
return ResPARAM;
res = InstDescribe(CouldBeA(Inst, land), stream, depth);
res = NextMethod(Inst, Land, describe)(inst, stream, depth);
if (res != ResOK)
return res;
@ -574,11 +586,12 @@ DEFINE_CLASS(Inst, LandClass, klass)
DEFINE_CLASS(Land, Land, klass)
{
INHERIT_CLASS(&klass->protocol, Land, Inst);
INHERIT_CLASS(&klass->instClassStruct, Land, Inst);
klass->instClassStruct.describe = LandAbsDescribe;
klass->instClassStruct.finish = LandAbsFinish;
klass->size = sizeof(LandStruct);
klass->init = LandAbsInit;
klass->sizeMethod = landNoSize;
klass->finish = LandAbsFinish;
klass->insert = landNoInsert;
klass->delete = landNoDelete;
klass->iterate = landNoIterate;
@ -587,14 +600,13 @@ DEFINE_CLASS(Land, Land, klass)
klass->findLast = landNoFind;
klass->findLargest = landNoFind;
klass->findInZones = landNoFindInZones;
klass->describe = LandAbsDescribe;
klass->sig = LandClassSig;
}
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2014-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* Copyright (C) 2014-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
* All rights reserved. This is an open source license. Contact
* Ravenbrook for commercial licensing options.
*

6
mps/code/lockix.c
View file

@ -1,7 +1,7 @@
/* lockix.c: RECURSIVE LOCKS FOR POSIX SYSTEMS
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .posix: The implementation uses a POSIX interface, and should be reusable
* for many Unix-like operating systems.
@ -122,7 +122,7 @@ void (LockClaim)(Lock lock)
res = pthread_mutex_lock(&lock->mut);
/* pthread_mutex_lock will error if we own the lock already. */
AVER(res == 0);
AVER(res == 0); /* <design/check/#.common> */
/* This should be the first claim. Now we own the mutex */
/* it is ok to check this. */
@ -245,7 +245,7 @@ void (LockReleaseGlobal)(void)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

6
mps/code/lockli.c
View file

@ -1,7 +1,7 @@
/* lockli.c: RECURSIVE LOCKS FOR POSIX SYSTEMS
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .linux: This implementation currently just supports LinuxThreads
* (platform MPS_OS_LI), Single Unix i/f.
@ -136,7 +136,7 @@ void (LockClaim)(Lock lock)
res = pthread_mutex_lock(&lock->mut);
/* pthread_mutex_lock will error if we own the lock already. */
AVER(res == 0);
AVER(res == 0); /* <design/check/#.common> */
/* This should be the first claim. Now we own the mutex */
/* it is ok to check this. */
@ -259,7 +259,7 @@ void (LockReleaseGlobal)(void)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

6
mps/code/lockw3.c
View file

@ -1,7 +1,7 @@
/* lockw3.c: RECURSIVE LOCKS IN WIN32
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .design: These are implemented using critical sections.
* See the section titled "Synchronization functions" in the Groups
@ -75,7 +75,7 @@ void (LockClaim)(Lock lock)
EnterCriticalSection(&lock->cs);
/* This should be the first claim. Now we are inside the
* critical section it is ok to check this. */
AVER(lock->claims == 0);
AVER(lock->claims == 0); /* <design/check/#.common> */
lock->claims = 1;
}
@ -158,7 +158,7 @@ void (LockReleaseGlobal)(void)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

2
mps/code/locus.c
View file

@ -315,7 +315,7 @@ void ChainDestroy(Chain chain)
size_t i;
AVERT(Chain, chain);
AVER(chain->activeTraces == TraceSetEMPTY);
AVER(chain->activeTraces == TraceSetEMPTY); /* <design/check/#.common> */
arena = chain->arena;
genCount = chain->genCount;

22
mps/code/mpm.c
View file

@ -1,7 +1,7 @@
/* mpm.c: GENERAL MPM SUPPORT
*
* $Id$
* Copyright (c) 2001-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .purpose: Miscellaneous support for the implementation of the MPM
* and pool classes.
@ -711,7 +711,7 @@ static Bool quickSorted(void *array[], Count length,
void QuickSort(void *array[], Count length,
QuickSortCompare compare, void *closure,
SortStruct *sortStruct)
SortStruct *sortStruct)
{
Index left, right, sp, lo, hi, leftLimit, rightBase;
void *pivot, *temp;
@ -770,15 +770,15 @@ void QuickSort(void *array[], Count length,
for later. */
AVER_CRITICAL(sp < sizeof sortStruct->stack / sizeof sortStruct->stack[0]);
if (leftLimit - left < right - rightBase) {
sortStruct->stack[sp].left = rightBase;
sortStruct->stack[sp].right = right;
++sp;
right = leftLimit;
sortStruct->stack[sp].left = rightBase;
sortStruct->stack[sp].right = right;
++sp;
right = leftLimit;
} else {
sortStruct->stack[sp].left = left;
sortStruct->stack[sp].right = leftLimit;
++sp;
left = rightBase;
sortStruct->stack[sp].left = left;
sortStruct->stack[sp].right = leftLimit;
++sp;
left = rightBase;
}
}
@ -799,7 +799,7 @@ void QuickSort(void *array[], Count length,
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

17
mps/code/mpm.h
View file

@ -1,7 +1,7 @@
/* mpm.h: MEMORY POOL MANAGER DEFINITIONS
*
* $Id$
* Copyright (c) 2001-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*
* .trans.bufferinit: The Buffer data structure has an Init field and
@ -177,8 +177,8 @@ extern Word RandomWord(void);
typedef Compare QuickSortCompare(void *left, void *right,
void *closure);
extern void QuickSort(void *array[], Count length,
QuickSortCompare compare, void *closure,
SortStruct *sortStruct);
QuickSortCompare compare, void *closure,
SortStruct *sortStruct);
/* Version Determination
@ -238,7 +238,7 @@ extern Size PoolTotalSize(Pool pool);
extern Size PoolFreeSize(Pool pool);
extern Res PoolAbsInit(Pool pool, Arena arena, PoolClass klass, ArgList arg);
extern void PoolAbsFinish(Pool pool);
extern void PoolAbsFinish(Inst inst);
extern Res PoolNoAlloc(Addr *pReturn, Pool pool, Size size);
extern Res PoolTrivAlloc(Addr *pReturn, Pool pool, Size size);
extern void PoolNoFree(Pool pool, Addr old, Size size);
@ -251,7 +251,7 @@ extern void PoolNoBufferEmpty(Pool pool, Buffer buffer,
Addr init, Addr limit);
extern void PoolTrivBufferEmpty(Pool pool, Buffer buffer,
Addr init, Addr limit);
extern Res PoolTrivDescribe(Pool pool, mps_lib_FILE *stream, Count depth);
extern Res PoolAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth);
extern Res PoolNoTraceBegin(Pool pool, Trace trace);
extern Res PoolTrivTraceBegin(Pool pool, Trace trace);
extern Res PoolNoAccess(Pool pool, Seg seg, Addr addr,
@ -670,10 +670,13 @@ extern void SegSetRankSet(Seg seg, RankSet rankSet);
extern void SegSetRankAndSummary(Seg seg, RankSet rankSet, RefSet summary);
extern Res SegMerge(Seg *mergedSegReturn, Seg segLo, Seg segHi);
extern Res SegSplit(Seg *segLoReturn, Seg *segHiReturn, Seg seg, Addr at);
extern Res SegAbsDescribe(Inst seg, mps_lib_FILE *stream, Count depth);
extern Res SegDescribe(Seg seg, mps_lib_FILE *stream, Count depth);
extern void SegSetSummary(Seg seg, RefSet summary);
extern Buffer SegBuffer(Seg seg);
extern Bool SegHasBuffer(Seg seg);
extern Bool SegBuffer(Buffer *bufferReturn, Seg seg);
extern void SegSetBuffer(Seg seg, Buffer buffer);
extern void SegUnsetBuffer(Seg seg);
extern Addr SegBufferScanLimit(Seg seg);
extern Bool SegCheck(Seg seg);
extern Bool GCSegCheck(GCSeg gcseg);
@ -1018,7 +1021,7 @@ DECLARE_CLASS(Land, Land, Inst);
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

13
mps/code/mpmss.c
View file

@ -1,7 +1,7 @@
/* mpmss.c: MPM STRESS TEST
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*/
@ -57,11 +57,12 @@ static mps_res_t stress(mps_arena_t arena, mps_pool_debug_option_s *options,
/* allocate a load of objects */
for (i=0; i<testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i);
res = mps_alloc((mps_addr_t *)&ps[i], pool, ss[i]);
res = mps_alloc(&obj, pool, ss[i]);
if (res != MPS_RES_OK)
return res;
ps[i] = obj;
allocated += alignUp(ss[i], align) + debugOverhead;
if (ss[i] >= sizeof(ps[i]))
*ps[i] = 1; /* Write something, so it gets swap. */
@ -93,10 +94,12 @@ static mps_res_t stress(mps_arena_t arena, mps_pool_debug_option_s *options,
}
/* allocate some new objects */
for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i);
res = mps_alloc((mps_addr_t *)&ps[i], pool, ss[i]);
res = mps_alloc(&obj, pool, ss[i]);
if (res != MPS_RES_OK)
return res;
ps[i] = obj;
allocated += alignUp(ss[i], align) + debugOverhead;
}
check_allocated_size(pool, allocated);
@ -241,7 +244,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

26
mps/code/mpmst.h
View file

@ -49,12 +49,11 @@
#define PoolClassSig ((Sig)0x519C7A55) /* SIGnature pool CLASS */
typedef struct mps_pool_class_s {
InstClassStruct protocol;
InstClassStruct instClassStruct;
size_t size; /* size of outer structure */
Attr attr; /* attributes */
PoolVarargsMethod varargs; /* convert deprecated varargs into keywords */
PoolInitMethod init; /* initialize the pool descriptor */
PoolFinishMethod finish; /* finish the pool descriptor */
PoolAllocMethod alloc; /* allocate memory from pool */
PoolFreeMethod free; /* free memory to pool */
PoolBufferFillMethod bufferFill; /* out-of-line reserve */
@ -76,7 +75,6 @@ typedef struct mps_pool_class_s {
PoolWalkMethod walk; /* walk over a segment */
PoolFreeWalkMethod freewalk; /* walk over free blocks */
PoolBufferClassMethod bufferClass; /* default BufferClass of pool */
PoolDescribeMethod describe; /* describe the contents of the pool */
PoolDebugMixinMethod debugMixin; /* find the debug mixin, if any */
PoolSizeMethod totalSize; /* total memory allocated from arena */
PoolSizeMethod freeSize; /* free memory (unused by client program) */
@ -218,18 +216,17 @@ typedef struct mps_message_s {
#define SegClassSig ((Sig)0x5195E9C7) /* SIGnature SEG CLass */
typedef struct SegClassStruct {
InstClassStruct protocol;
InstClassStruct instClassStruct;
size_t size; /* size of outer structure */
SegInitMethod init; /* initialize the segment */
SegFinishMethod finish; /* finish the segment */
SegSetSummaryMethod setSummary; /* set the segment summary */
SegBufferMethod buffer; /* get the segment buffer */
SegSetBufferMethod setBuffer; /* set the segment buffer */
SegUnsetBufferMethod unsetBuffer; /* unset the segment buffer */
SegSetGreyMethod setGrey; /* change greyness of segment */
SegSetWhiteMethod setWhite; /* change whiteness of segment */
SegSetRankSetMethod setRankSet; /* change rank set of segment */
SegSetRankSummaryMethod setRankSummary; /* change rank set & summary */
SegDescribeMethod describe; /* describe the contents of the seg */
SegMergeMethod merge; /* merge two adjacent segments */
SegSplitMethod split; /* split a segment into two */
Sig sig; /* .class.end-sig */
@ -306,14 +303,12 @@ typedef struct LocusPrefStruct { /* locus placement preferences */
#define BufferClassSig ((Sig)0x519B0FC7) /* SIGnature BUFfer CLass */
typedef struct BufferClassStruct {
InstClassStruct protocol;
InstClassStruct instClassStruct;
size_t size; /* size of outer structure */
BufferVarargsMethod varargs; /* parse obsolete varargs */
BufferInitMethod init; /* initialize the buffer */
BufferFinishMethod finish; /* finish the buffer */
BufferAttachMethod attach; /* attach the buffer */
BufferDetachMethod detach; /* detach the buffer */
BufferDescribeMethod describe;/* describe the contents of the buffer */
BufferSegMethod seg; /* seg of buffer */
BufferRankSetMethod rankSet; /* rank set of buffer */
BufferSetRankSetMethod setRankSet; /* change rank set of buffer */
@ -497,11 +492,10 @@ typedef struct TraceStruct {
#define ArenaClassSig ((Sig)0x519A6C1A) /* SIGnature ARena CLAss */
typedef struct mps_arena_class_s {
InstClassStruct protocol;
InstClassStruct instClassStruct;
size_t size; /* size of outer structure */
ArenaVarargsMethod varargs;
ArenaInitMethod init;
ArenaFinishMethod finish;
ArenaCreateMethod create;
ArenaDestroyMethod destroy;
ArenaPurgeSpareMethod purgeSpare;
@ -511,7 +505,6 @@ typedef struct mps_arena_class_s {
ArenaChunkInitMethod chunkInit;
ArenaChunkFinishMethod chunkFinish;
ArenaCompactMethod compact;
ArenaDescribeMethod describe;
ArenaPagesMarkAllocatedMethod pagesMarkAllocated;
Sig sig;
} ArenaClassStruct;
@ -576,11 +569,10 @@ typedef struct GlobalsStruct {
#define LandClassSig ((Sig)0x5197A4DC) /* SIGnature LAND Class */
typedef struct LandClassStruct {
InstClassStruct protocol;
InstClassStruct instClassStruct;
size_t size; /* size of outer structure */
LandSizeMethod sizeMethod; /* total size of ranges in land */
LandInitMethod init; /* initialize the land */
LandFinishMethod finish; /* finish the land */
LandInsertMethod insert; /* insert a range into the land */
LandDeleteMethod delete; /* delete a range from the land */
LandIterateMethod iterate; /* iterate over ranges in the land */
@ -589,7 +581,6 @@ typedef struct LandClassStruct {
LandFindMethod findLast; /* find last range of given size */
LandFindMethod findLargest; /* find largest range */
LandFindInZonesMethod findInZones; /* find first range of given size in zone set */
LandDescribeMethod describe; /* describe the land */
Sig sig; /* .class.end-sig */
} LandClassStruct;
@ -696,7 +687,9 @@ typedef struct SortStruct {
typedef struct ShieldStruct {
Sig sig; /* design.mps.sig */
Bool inside; /* design.mps.shield.def.inside */
BOOLFIELD(inside); /* design.mps.shield.def.inside */
BOOLFIELD(suspended); /* mutator suspended? */
BOOLFIELD(queuePending); /* queue insertion pending? */
Seg *queue; /* queue of unsynced segs */
Count length; /* number of elements in shield queue */
Index next; /* next free element in shield queue */
@ -704,7 +697,6 @@ typedef struct ShieldStruct {
Count depth; /* sum of depths of all segs */
Count unsynced; /* number of unsynced segments */
Count holds; /* number of holds */
Bool suspended; /* mutator suspended? */
SortStruct sortStruct; /* workspace for queue sort */
} ShieldStruct;

13
mps/code/mpmtypes.h
View file

@ -114,7 +114,6 @@ typedef void (*ArenaVarargsMethod)(ArgStruct args[], va_list varargs);
typedef Res (*ArenaCreateMethod)(Arena *arenaReturn, ArgList args);
typedef void (*ArenaDestroyMethod)(Arena arena);
typedef Res (*ArenaInitMethod)(Arena arena, Size grainSize, ArgList args);
typedef void (*ArenaFinishMethod)(Arena arena);
typedef Size (*ArenaPurgeSpareMethod)(Arena arena, Size size);
typedef Res (*ArenaExtendMethod)(Arena arena, Addr base, Size size);
typedef Res (*ArenaGrowMethod)(Arena arena, LocusPref pref, Size size);
@ -122,7 +121,6 @@ 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, Count depth);
typedef Res (*ArenaPagesMarkAllocatedMethod)(Arena arena, Chunk chunk,
Index baseIndex, Count pages,
Pool pool);
@ -153,16 +151,15 @@ typedef void (*FreeBlockVisitor)(Addr base, Addr limit, Pool pool, void *p);
typedef Res (*SegInitMethod)(Seg seg, Pool pool, Addr base, Size size,
ArgList args);
typedef void (*SegFinishMethod)(Seg seg);
typedef void (*SegSetGreyMethod)(Seg seg, TraceSet grey);
typedef void (*SegSetWhiteMethod)(Seg seg, TraceSet white);
typedef void (*SegSetRankSetMethod)(Seg seg, RankSet rankSet);
typedef void (*SegSetRankSummaryMethod)(Seg seg, RankSet rankSet,
RefSet summary);
typedef void (*SegSetSummaryMethod)(Seg seg, RefSet summary);
typedef Buffer (*SegBufferMethod)(Seg seg);
typedef Bool (*SegBufferMethod)(Buffer *bufferReturn, Seg seg);
typedef void (*SegSetBufferMethod)(Seg seg, Buffer buffer);
typedef Res (*SegDescribeMethod)(Seg seg, mps_lib_FILE *stream, Count depth);
typedef void (*SegUnsetBufferMethod)(Seg seg);
typedef Res (*SegMergeMethod)(Seg seg, Seg segHi,
Addr base, Addr mid, Addr limit);
typedef Res (*SegSplitMethod)(Seg seg, Seg segHi,
@ -172,7 +169,6 @@ typedef Res (*SegSplitMethod)(Seg seg, Seg segHi,
typedef void (*BufferVarargsMethod)(ArgStruct args[], va_list varargs);
typedef Res (*BufferInitMethod)(Buffer buffer, Pool pool, Bool isMutator, ArgList args);
typedef void (*BufferFinishMethod)(Buffer buffer);
typedef void (*BufferAttachMethod)(Buffer buffer, Addr base, Addr limit,
Addr init, Size size);
typedef void (*BufferDetachMethod)(Buffer buffer);
@ -180,7 +176,6 @@ typedef Seg (*BufferSegMethod)(Buffer buffer);
typedef RankSet (*BufferRankSetMethod)(Buffer buffer);
typedef void (*BufferSetRankSetMethod)(Buffer buffer, RankSet rankSet);
typedef void (*BufferReassignSegMethod)(Buffer buffer, Seg seg);
typedef Res (*BufferDescribeMethod)(Buffer buffer, mps_lib_FILE *stream, Count depth);
/* Pool*Method -- see <design/class-interface/> */
@ -189,7 +184,6 @@ typedef Res (*BufferDescribeMethod)(Buffer buffer, mps_lib_FILE *stream, Count d
typedef void (*PoolVarargsMethod)(ArgStruct args[], va_list varargs);
typedef Res (*PoolInitMethod)(Pool pool, Arena arena, PoolClass klass, ArgList args);
typedef void (*PoolFinishMethod)(Pool pool);
typedef Res (*PoolAllocMethod)(Addr *pReturn, Pool pool, Size size);
typedef void (*PoolFreeMethod)(Pool pool, Addr old, Size size);
typedef Res (*PoolBufferFillMethod)(Addr *baseReturn, Addr *limitReturn,
@ -222,7 +216,6 @@ typedef void (*PoolWalkMethod)(Pool pool, Seg seg, FormattedObjectsVisitor f,
void *v, size_t s);
typedef void (*PoolFreeWalkMethod)(Pool pool, FreeBlockVisitor f, void *p);
typedef BufferClass (*PoolBufferClassMethod)(void);
typedef Res (*PoolDescribeMethod)(Pool pool, mps_lib_FILE *stream, Count depth);
typedef PoolDebugMixin (*PoolDebugMixinMethod)(Pool pool);
typedef Size (*PoolSizeMethod)(Pool pool);
@ -255,7 +248,6 @@ typedef struct TraceMessageStruct *TraceMessage; /* trace end */
/* Land*Method -- see <design/land/> */
typedef Res (*LandInitMethod)(Land land, Arena arena, Align alignment, ArgList args);
typedef void (*LandFinishMethod)(Land land);
typedef Size (*LandSizeMethod)(Land land);
typedef Res (*LandInsertMethod)(Range rangeReturn, Land land, Range range);
typedef Res (*LandDeleteMethod)(Range rangeReturn, Land land, Range range);
@ -265,7 +257,6 @@ typedef Bool (*LandIterateMethod)(Land land, LandVisitor visitor, void *closure)
typedef Bool (*LandIterateAndDeleteMethod)(Land land, LandDeleteVisitor visitor, void *closure);
typedef Bool (*LandFindMethod)(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete);
typedef Res (*LandFindInZonesMethod)(Bool *foundReturn, Range rangeReturn, Range oldRangeReturn, Land land, Size size, ZoneSet zoneSet, Bool high);
typedef Res (*LandDescribeMethod)(Land land, mps_lib_FILE *stream, Count depth);
/* CONSTANTS */

20
mps/code/mpsi.c
View file

@ -1,7 +1,7 @@
/* mpsi.c: MEMORY POOL SYSTEM C INTERFACE LAYER
*
* $Id$
* Copyright (c) 2001-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (c) 2002 Global Graphics Software.
*
* .purpose: This code bridges between the MPS interface to C,
@ -745,16 +745,16 @@ mps_res_t mps_alloc(mps_addr_t *p_o, mps_pool_t pool, size_t size)
Addr p;
Res res;
AVER(TESTT(Pool, pool));
AVER_CRITICAL(TESTT(Pool, pool));
arena = PoolArena(pool);
ArenaEnter(arena);
ArenaPoll(ArenaGlobals(arena)); /* .poll */
AVER(p_o != NULL);
AVERT(Pool, pool);
AVER(size > 0);
AVER_CRITICAL(p_o != NULL);
AVERT_CRITICAL(Pool, pool);
AVER_CRITICAL(size > 0);
/* Note: class may allow unaligned size, see */
/* <design/class-interface/#alloc.size.align>. */
/* Rest ignored, see .varargs. */
@ -787,13 +787,13 @@ void mps_free(mps_pool_t pool, mps_addr_t p, size_t size)
{
Arena arena;
AVER(TESTT(Pool, pool));
AVER_CRITICAL(TESTT(Pool, pool));
arena = PoolArena(pool);
ArenaEnter(arena);
AVERT(Pool, pool);
AVER(size > 0);
AVERT_CRITICAL(Pool, pool);
AVER_CRITICAL(size > 0);
/* Note: class may allow unaligned size, see */
/* <design/class-interface/#alloc.size.align>. */
@ -1060,7 +1060,7 @@ mps_res_t mps_ap_fill(mps_addr_t *p_o, mps_ap_t mps_ap, size_t size)
AVER(p_o != NULL);
AVERT(Buffer, buf);
AVER(size > 0);
AVER(SizeIsAligned(size, BufferPool(buf)->alignment));
AVER(SizeIsAligned(size, BufferPool(buf)->alignment)); /* <design/check/#.common> */
res = BufferFill(&p, buf, size);
@ -2141,7 +2141,7 @@ void _mps_args_set_key(mps_arg_s args[MPS_ARGS_MAX], unsigned i,
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

52
mps/code/mpsicv.c
View file

@ -1,7 +1,7 @@
/* mpsicv.c: MPSI COVERAGE TEST
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (c) 2002 Global Graphics Software.
*/
@ -338,7 +338,8 @@ static void *test(void *arg, size_t s)
mps_arena_t arena;
mps_fmt_t format;
mps_chain_t chain;
mps_root_t exactRoot, ambigRoot, singleRoot, fmtRoot;
mps_root_t exactAreaRoot, exactTableRoot, ambigAreaRoot, ambigTableRoot,
singleRoot, fmtRoot;
unsigned long i;
/* Leave arena clamped until we have allocated this many objects.
is 0 when arena has not been clamped. */
@ -386,14 +387,29 @@ static void *test(void *arg, size_t s)
ambigRoots[j] = rnd_addr();
}
die(mps_root_create_table_masked(&exactRoot, arena,
die(mps_root_create_area_tagged(&exactAreaRoot, arena,
mps_rank_exact(), (mps_rm_t)0,
&exactRoots[0],
&exactRoots[exactRootsCOUNT / 2],
mps_scan_area_tagged,
MPS_WORD_CONST(1), 0),
"root_create_area_tagged(exact)");
die(mps_root_create_table_masked(&exactTableRoot, arena,
mps_rank_exact(), (mps_rm_t)0,
&exactRoots[0], exactRootsCOUNT,
&exactRoots[exactRootsCOUNT / 2],
(exactRootsCOUNT + 1) / 2,
MPS_WORD_CONST(1)),
"root_create_table(exact)");
die(mps_root_create_table(&ambigRoot, arena,
"root_create_table_masked(exact)");
die(mps_root_create_area(&ambigAreaRoot, arena,
mps_rank_ambig(), (mps_rm_t)0,
&ambigRoots[0],
&ambigRoots[ambigRootsCOUNT / 2],
mps_scan_area, NULL),
"root_create_area(ambig)");
die(mps_root_create_table(&ambigTableRoot, arena,
mps_rank_ambig(), (mps_rm_t)0,
&ambigRoots[0], ambigRootsCOUNT),
&ambigRoots[ambigRootsCOUNT / 2],
(ambigRootsCOUNT + 1) / 2),
"root_create_table(ambig)");
obj = objNULL;
@ -519,8 +535,10 @@ static void *test(void *arg, size_t s)
mps_ap_destroy(ap);
mps_root_destroy(fmtRoot);
mps_root_destroy(singleRoot);
mps_root_destroy(exactRoot);
mps_root_destroy(ambigRoot);
mps_root_destroy(exactAreaRoot);
mps_root_destroy(exactTableRoot);
mps_root_destroy(ambigAreaRoot);
mps_root_destroy(ambigTableRoot);
mps_pool_destroy(amcpool);
mps_chain_destroy(chain);
mps_fmt_destroy(format);
@ -551,15 +569,25 @@ int main(int argc, char *argv[])
} MPS_ARGS_END(args);
die(mps_thread_reg(&thread, arena), "thread_reg");
if (rnd() % 2) {
switch (rnd() % 3) {
default:
case 0:
die(mps_root_create_reg(&reg_root, arena,
mps_rank_ambig(), (mps_rm_t)0,
thread, &mps_stack_scan_ambig,
marker, (size_t)0),
"root_create_reg");
} else {
break;
case 1:
die(mps_root_create_thread(&reg_root, arena, thread, marker),
"root_create_thread");
break;
case 2:
die(mps_root_create_thread_scanned(&reg_root, arena, mps_rank_ambig(),
(mps_rm_t)0, thread, mps_scan_area,
NULL, marker),
"root_create_thread");
break;
}
mps_tramp(&r, test, arena, 0);
@ -574,7 +602,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

18
mps/code/mv2test.c
View file

@ -1,7 +1,7 @@
/* mv2test.c: POOLMVT STRESS TEST
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*/
#include <math.h>
@ -102,13 +102,15 @@ static mps_res_t stress(mps_arena_t arena, mps_align_t align,
/* allocate a load of objects */
for(i=0; i<TEST_SET_SIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i);
res = make((mps_addr_t *)&ps[i], ap, ss[i], align);
if(res != MPS_RES_OK)
res = make(&obj, ap, ss[i], align);
if (res != MPS_RES_OK) {
ss[i] = 0;
else
} else {
ps[i]= obj;
*ps[i] = 1; /* Write something, so it gets swap. */
}
if (verbose) {
if (i && i%4==0)
@ -146,10 +148,12 @@ static mps_res_t stress(mps_arena_t arena, mps_align_t align,
}
/* allocate some new objects */
for(i=x; i<TEST_SET_SIZE; ++i) {
mps_addr_t obj;
size_t s = (*size)(i);
res = make((mps_addr_t *)&ps[i], ap, s, align);
res = make(&obj, ap, s, align);
if(res != MPS_RES_OK)
break;
ps[i] = obj;
ss[i] = s;
if (verbose) {
@ -218,7 +222,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

102
mps/code/pool.c
View file

@ -1,7 +1,7 @@
/* pool.c: POOL IMPLEMENTATION
*
* $Id$
* Copyright (c) 2001-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2001 Global Graphics Software.
*
* DESIGN
@ -37,13 +37,12 @@ SRCID(pool, "$Id$");
Bool PoolClassCheck(PoolClass klass)
{
CHECKD(InstClass, &klass->protocol);
CHECKD(InstClass, &klass->instClassStruct);
CHECKL(klass->size >= sizeof(PoolStruct));
CHECKL(AttrCheck(klass->attr));
CHECKL(!(klass->attr & AttrMOVINGGC) || (klass->attr & AttrGC));
CHECKL(FUNCHECK(klass->varargs));
CHECKL(FUNCHECK(klass->init));
CHECKL(FUNCHECK(klass->finish));
CHECKL(FUNCHECK(klass->alloc));
CHECKL(FUNCHECK(klass->free));
CHECKL(FUNCHECK(klass->bufferFill));
@ -65,24 +64,23 @@ Bool PoolClassCheck(PoolClass klass)
CHECKL(FUNCHECK(klass->walk));
CHECKL(FUNCHECK(klass->freewalk));
CHECKL(FUNCHECK(klass->bufferClass));
CHECKL(FUNCHECK(klass->describe));
CHECKL(FUNCHECK(klass->debugMixin));
CHECKL(FUNCHECK(klass->totalSize));
CHECKL(FUNCHECK(klass->freeSize));
/* Check that pool classes overide sets of related methods. */
CHECKL((klass->init == PoolAbsInit) == (klass->finish == PoolAbsFinish));
CHECKL((klass->init == PoolAbsInit) ==
(klass->instClassStruct.finish == PoolAbsFinish));
CHECKL((klass->bufferFill == PoolNoBufferFill) ==
(klass->bufferEmpty == PoolNoBufferEmpty));
(klass->bufferEmpty == PoolNoBufferEmpty));
CHECKL((klass->framePush == PoolNoFramePush) ==
(klass->framePop == PoolNoFramePop));
(klass->framePop == PoolNoFramePop));
CHECKL((klass->rampBegin == PoolNoRampBegin) ==
(klass->rampEnd == PoolNoRampEnd));
(klass->rampEnd == PoolNoRampEnd));
/* Check that pool classes that set attributes also override the
methods they imply. */
/* .check.ams.walk: Can't enforce this one until job003738 is resolved. */
/* CHECKL(((klass->attr & AttrFMT) == 0) == (klass->walk == PoolNoWalk)); */
CHECKL(((klass->attr & AttrFMT) == 0) == (klass->walk == PoolNoWalk));
if (klass != &CLASS_STATIC(AbstractCollectPool)) {
CHECKL(((klass->attr & AttrGC) == 0) == (klass->fix == PoolNoFix));
CHECKL(((klass->attr & AttrGC) == 0) == (klass->fixEmergency == PoolNoFix));
@ -197,7 +195,7 @@ failControlAlloc:
void PoolFinish(Pool pool)
{
AVERT(Pool, pool);
Method(Pool, pool, finish)(pool);
Method(Inst, pool, finish)(MustBeA(Inst, pool));
}
@ -227,22 +225,24 @@ BufferClass PoolDefaultBufferClass(Pool pool)
}
/* PoolAlloc -- allocate a block of memory from a pool */
/* PoolAlloc -- allocate a block of memory from a pool
*
* .alloc.critical: In manual-allocation-bound programs this is on the
* critical path.
*/
Res PoolAlloc(Addr *pReturn, Pool pool, Size size)
{
Res res;
AVER(pReturn != NULL);
AVERT(Pool, pool);
AVER(size > 0);
AVER_CRITICAL(pReturn != NULL);
AVERT_CRITICAL(Pool, pool);
AVER_CRITICAL(size > 0);
res = Method(Pool, pool, alloc)(pReturn, pool, size);
if (res != ResOK)
return res;
/* Make sure that the allocated address was in the pool's memory. */
/* .hasaddr.critical: The PoolHasAddr check is expensive, and in */
/* allocation-bound programs this is on the critical path. */
AVER_CRITICAL(PoolHasAddr(pool, *pReturn));
/* All allocations should be aligned to the pool's alignment */
AVER_CRITICAL(AddrIsAligned(*pReturn, pool->alignment));
@ -257,16 +257,20 @@ Res PoolAlloc(Addr *pReturn, Pool pool, Size size)
}
/* PoolFree -- deallocate a block of memory allocated from the pool */
/* PoolFree -- deallocate a block of memory allocated from the pool
*
* .free.critical: In manual-allocation-bound programs this is on the
* critical path.
*/
void PoolFree(Pool pool, Addr old, Size size)
{
AVERT(Pool, pool);
AVER(old != NULL);
AVERT_CRITICAL(Pool, pool);
AVER_CRITICAL(old != NULL);
/* The pool methods should check that old is in pool. */
AVER(size > 0);
AVER(AddrIsAligned(old, pool->alignment));
AVER(PoolHasRange(pool, old, AddrAdd(old, size)));
AVER_CRITICAL(size > 0);
AVER_CRITICAL(AddrIsAligned(old, pool->alignment));
AVER_CRITICAL(PoolHasRange(pool, old, AddrAdd(old, size)));
Method(Pool, pool, free)(pool, old, size);
@ -490,51 +494,7 @@ Size PoolFreeSize(Pool pool)
Res PoolDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
{
Res res;
Ring node, nextNode;
PoolClass klass;
if (!TESTC(AbstractPool, pool))
return ResPARAM;
if (stream == NULL)
return ResPARAM;
klass = ClassOfPoly(Pool, pool);
res = WriteF(stream, depth,
"Pool $P ($U) {\n", (WriteFP)pool, (WriteFU)pool->serial,
" class $P (\"$S\")\n",
(WriteFP)klass, (WriteFS)ClassName(klass),
" arena $P ($U)\n",
(WriteFP)pool->arena, (WriteFU)pool->arena->serial,
" alignment $W\n", (WriteFW)pool->alignment,
NULL);
if (res != ResOK)
return res;
if (NULL != pool->format) {
res = FormatDescribe(pool->format, stream, depth + 2);
if (res != ResOK)
return res;
}
res = Method(Pool, pool, describe)(pool, stream, depth + 2);
if (res != ResOK)
return res;
RING_FOR(node, &pool->bufferRing, nextNode) {
Buffer buffer = RING_ELT(Buffer, poolRing, node);
res = BufferDescribe(buffer, stream, depth + 2);
if (res != ResOK)
return res;
}
res = WriteF(stream, depth,
"} Pool $P ($U)\n", (WriteFP)pool, (WriteFU)pool->serial,
NULL);
if (res != ResOK)
return res;
return ResOK;
return Method(Inst, pool, describe)(MustBeA(Inst, pool), stream, depth);
}
@ -640,8 +600,8 @@ Bool PoolHasRange(Pool pool, Addr base, Addr limit)
Arena arena;
Bool managed;
AVERT(Pool, pool);
AVER(base < limit);
AVERT_CRITICAL(Pool, pool);
AVER_CRITICAL(base < limit);
arena = PoolArena(pool);
managed = PoolOfRange(&rangePool, arena, base, limit);
@ -651,7 +611,7 @@ Bool PoolHasRange(Pool pool, Addr base, Addr limit)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

53
mps/code/poolabs.c
View file

@ -154,8 +154,10 @@ Res PoolAbsInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
/* PoolAbsFinish -- finish an abstract pool instance */
void PoolAbsFinish(Pool pool)
void PoolAbsFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
/* Detach the pool from the arena and format, and unsig it. */
RingRemove(PoolArenaRing(pool));
@ -184,12 +186,13 @@ DEFINE_CLASS(Inst, PoolClass, klass)
DEFINE_CLASS(Pool, AbstractPool, klass)
{
INHERIT_CLASS(&klass->protocol, AbstractPool, Inst);
INHERIT_CLASS(&klass->instClassStruct, AbstractPool, Inst);
klass->instClassStruct.describe = PoolAbsDescribe;
klass->instClassStruct.finish = PoolAbsFinish;
klass->size = sizeof(PoolStruct);
klass->attr = 0;
klass->varargs = ArgTrivVarargs;
klass->init = PoolAbsInit;
klass->finish = PoolAbsFinish;
klass->alloc = PoolNoAlloc;
klass->free = PoolNoFree;
klass->bufferFill = PoolNoBufferFill;
@ -211,7 +214,6 @@ DEFINE_CLASS(Pool, AbstractPool, klass)
klass->walk = PoolNoWalk;
klass->freewalk = PoolTrivFreeWalk;
klass->bufferClass = PoolNoBufferClass;
klass->describe = PoolTrivDescribe;
klass->debugMixin = PoolNoDebugMixin;
klass->totalSize = PoolNoSize;
klass->freeSize = PoolNoSize;
@ -353,13 +355,44 @@ void PoolTrivBufferEmpty(Pool pool, Buffer buffer, Addr init, Addr limit)
}
Res PoolTrivDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
Res PoolAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
AVERT(Pool, pool);
AVER(stream != NULL);
return WriteF(stream, depth,
"No class-specific description available.\n",
NULL);
Pool pool = CouldBeA(AbstractPool, inst);
Res res;
Ring node, nextNode;
if (!TESTC(AbstractPool, pool))
return ResPARAM;
if (stream == NULL)
return ResPARAM;
res = InstDescribe(CouldBeA(Inst, pool), stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2,
"serial $U\n", (WriteFU)pool->serial,
"arena $P ($U)\n",
(WriteFP)pool->arena, (WriteFU)pool->arena->serial,
"alignment $W\n", (WriteFW)pool->alignment,
NULL);
if (res != ResOK)
return res;
if (pool->format != NULL) {
res = FormatDescribe(pool->format, stream, depth + 2);
if (res != ResOK)
return res;
}
RING_FOR(node, &pool->bufferRing, nextNode) {
Buffer buffer = RING_ELT(Buffer, poolRing, node);
res = BufferDescribe(buffer, stream, depth + 2);
if (res != ResOK)
return res;
}
return ResOK;
}

125
mps/code/poolamc.c
View file

@ -197,8 +197,7 @@ static void AMCSegSketch(Seg seg, char *pbSketch, size_t cbSketch)
pbSketch[2] = 'W'; /* White */
}
buffer = SegBuffer(seg);
if(buffer == NULL) {
if (!SegBuffer(&buffer, seg)) {
pbSketch[3] = '_';
} else {
Bool mut = BufferIsMutator(buffer);
@ -234,24 +233,26 @@ static void AMCSegSketch(Seg seg, char *pbSketch, size_t cbSketch)
*
* See <design/poolamc/#seg-describe>.
*/
static Res AMCSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
static Res AMCSegDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
amcSeg amcseg = CouldBeA(amcSeg, inst);
Seg seg = CouldBeA(Seg, amcseg);
Res res;
amcSeg amcseg = CouldBeA(amcSeg, seg);
Pool pool;
Addr i, p, base, limit, init;
Align step;
Size row;
char abzSketch[5];
Buffer buffer;
if(!TESTC(amcSeg, amcseg))
if (!TESTC(amcSeg, amcseg))
return ResPARAM;
if(stream == NULL)
if (stream == NULL)
return ResPARAM;
/* Describe the superclass fields first via next-method call */
res = NextMethod(Seg, amcSeg, describe)(seg, stream, depth);
if(res != ResOK)
res = NextMethod(Inst, amcSeg, describe)(inst, stream, depth);
if (res != ResOK)
return res;
pool = SegPool(seg);
@ -262,16 +263,9 @@ static Res AMCSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
p = AddrAdd(base, pool->format->headerSize);
limit = SegLimit(seg);
res = WriteF(stream, depth,
"AMC seg $P [$A,$A){\n",
(WriteFP)seg, (WriteFA)base, (WriteFA)limit,
NULL);
if(res != ResOK)
return res;
if(amcSegHasNailboard(seg)) {
if (amcSegHasNailboard(seg)) {
res = WriteF(stream, depth + 2, "Boarded\n", NULL);
} else if(SegNailed(seg) == TraceSetEMPTY) {
} else if (SegNailed(seg) == TraceSetEMPTY) {
res = WriteF(stream, depth + 2, "Mobile\n", NULL);
} else {
res = WriteF(stream, depth + 2, "Stuck\n", NULL);
@ -281,32 +275,32 @@ static Res AMCSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
res = WriteF(stream, depth + 2,
"Map: *===:object @+++:nails bbbb:buffer\n", NULL);
if(res != ResOK)
if (res != ResOK)
return res;
if(SegBuffer(seg) != NULL)
init = BufferGetInit(SegBuffer(seg));
if (SegBuffer(&buffer, seg))
init = BufferGetInit(buffer);
else
init = limit;
for(i = base; i < limit; i = AddrAdd(i, row)) {
for (i = base; i < limit; i = AddrAdd(i, row)) {
Addr j;
char c;
res = WriteF(stream, depth + 2, "$A ", (WriteFA)i, NULL);
if(res != ResOK)
if (res != ResOK)
return res;
/* @@@@ This misses a header-sized pad at the end. */
for(j = i; j < AddrAdd(i, row); j = AddrAdd(j, step)) {
if(j >= limit)
for (j = i; j < AddrAdd(i, row); j = AddrAdd(j, step)) {
if (j >= limit)
c = ' '; /* if seg is not a whole number of print rows */
else if(j >= init)
else if (j >= init)
c = 'b';
else {
Bool nailed = amcSegHasNailboard(seg)
&& NailboardGet(amcSegNailboard(seg), j);
if(j == p) {
if (j == p) {
c = (nailed ? '@' : '*');
p = (pool->format->skip)(p);
} else {
@ -314,12 +308,12 @@ static Res AMCSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
}
}
res = WriteF(stream, 0, "$C", (WriteFC)c, NULL);
if(res != ResOK)
if (res != ResOK)
return res;
}
res = WriteF(stream, 0, "\n", NULL);
if(res != ResOK)
if (res != ResOK)
return res;
}
@ -328,10 +322,6 @@ static Res AMCSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
if(res != ResOK)
return res;
res = WriteF(stream, depth, "} AMC Seg $P\n", (WriteFP)seg, NULL);
if(res != ResOK)
return res;
return ResOK;
}
@ -342,9 +332,9 @@ DEFINE_CLASS(Seg, amcSeg, klass)
{
INHERIT_CLASS(klass, amcSeg, GCSeg);
SegClassMixInNoSplitMerge(klass); /* no support for this (yet) */
klass->instClassStruct.describe = AMCSegDescribe;
klass->size = sizeof(amcSegStruct);
klass->init = AMCSegInit;
klass->describe = AMCSegDescribe;
}
@ -519,11 +509,12 @@ static Res AMCBufInit(Buffer buffer, Pool pool, Bool isMutator, ArgList args)
/* AMCBufFinish -- Finish an amcBuf */
static void AMCBufFinish(Buffer buffer)
static void AMCBufFinish(Inst inst)
{
Buffer buffer = MustBeA(Buffer, inst);
amcBuf amcbuf = MustBeA(amcBuf, buffer);
amcbuf->sig = SigInvalid;
NextMethod(Buffer, amcBuf, finish)(buffer);
NextMethod(Inst, amcBuf, finish)(inst);
}
@ -532,9 +523,9 @@ static void AMCBufFinish(Buffer buffer)
DEFINE_CLASS(Buffer, amcBuf, klass)
{
INHERIT_CLASS(klass, amcBuf, SegBuf);
klass->instClassStruct.finish = AMCBufFinish;
klass->size = sizeof(amcBufStruct);
klass->init = AMCBufInit;
klass->finish = AMCBufFinish;
}
@ -809,7 +800,7 @@ failGenAlloc:
}
ControlFree(arena, amc->gen, genArraySize);
failGensAlloc:
PoolAbsFinish(pool);
NextMethod(Inst, AMCZPool, finish)(MustBeA(Inst, pool));
return res;
}
@ -834,8 +825,9 @@ static Res AMCZInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
*
* See <design/poolamc/#finish>.
*/
static void AMCFinish(Pool pool)
static void AMCFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
AMC amc = MustBeA(AMCZPool, pool);
Ring ring;
Ring node, nextNode;
@ -878,7 +870,8 @@ static void AMCFinish(Pool pool)
}
amc->sig = SigInvalid;
PoolAbsFinish(pool);
NextMethod(Inst, AMCZPool, finish)(inst);
}
@ -1111,8 +1104,7 @@ static Res AMCWhiten(Pool pool, Trace trace, Seg seg)
AVERT(Trace, trace);
buffer = SegBuffer(seg);
if(buffer != NULL) {
if (SegBuffer(&buffer, seg)) {
AVERT(Buffer, buffer);
if(!BufferIsMutator(buffer)) { /* forwarding buffer */
@ -1261,6 +1253,7 @@ static Res amcScanNailedOnce(Bool *totalReturn, Bool *moreReturn,
Addr p, limit;
Nailboard board;
Res res;
Buffer buffer;
EVENT3(AMCScanBegin, amc, seg, ss); /* TODO: consider using own event */
@ -1269,8 +1262,8 @@ static Res amcScanNailedOnce(Bool *totalReturn, Bool *moreReturn,
NailboardClearNewNails(board);
p = SegBase(seg);
while(SegBuffer(seg) != NULL) {
limit = BufferScanLimit(SegBuffer(seg));
while (SegBuffer(&buffer, seg)) {
limit = BufferScanLimit(buffer);
if(p >= limit) {
AVER(p == limit);
goto returnGood;
@ -1353,6 +1346,7 @@ static Res AMCScan(Bool *totalReturn, ScanState ss, Pool pool, Seg seg)
Format format;
AMC amc = MustBeA(AMCZPool, pool);
Res res;
Buffer buffer;
AVER(totalReturn != NULL);
AVERT(ScanState, ss);
@ -1369,8 +1363,8 @@ static Res AMCScan(Bool *totalReturn, ScanState ss, Pool pool, Seg seg)
base = AddrAdd(SegBase(seg), format->headerSize);
/* <design/poolamc/#seg-scan.loop> */
while(SegBuffer(seg) != NULL) {
limit = AddrAdd(BufferScanLimit(SegBuffer(seg)),
while (SegBuffer(&buffer, seg)) {
limit = AddrAdd(BufferScanLimit(buffer),
format->headerSize);
if(base >= limit) {
/* @@@@ Are we sure we don't need scan the rest of the */
@ -1730,13 +1724,13 @@ static void amcReclaimNailed(Pool pool, Trace trace, Seg seg)
/* Free the seg if we can; fixes .nailboard.limitations.middle. */
if(preservedInPlaceCount == 0
&& (SegBuffer(seg) == NULL)
&& (!SegHasBuffer(seg))
&& (SegNailed(seg) == TraceSetEMPTY)) {
amcGen gen = amcSegGen(seg);
/* We may not free a buffered seg. */
AVER(SegBuffer(seg) == NULL);
AVER(!SegHasBuffer(seg));
PoolGenFree(&gen->pgen, seg, 0, SegSize(seg), 0, MustBeA(amcSeg, seg)->deferred);
}
@ -1778,7 +1772,7 @@ static void AMCReclaim(Pool pool, Trace trace, Seg seg)
/* We may not free a buffered seg. (But all buffered + condemned */
/* segs should have been nailed anyway). */
AVER(SegBuffer(seg) == NULL);
AVER(!SegHasBuffer(seg));
STATISTIC(trace->reclaimSize += SegSize(seg));
@ -1895,6 +1889,7 @@ static Res AMCAddrObject(Addr *pReturn, Pool pool, Seg seg, Addr addr)
Res res;
Arena arena;
Addr base, limit; /* range of objects on segment */
Buffer buffer;
AVER(pReturn != NULL);
AVERT(Pool, pool);
@ -1905,7 +1900,7 @@ static Res AMCAddrObject(Addr *pReturn, Pool pool, Seg seg, Addr addr)
arena = PoolArena(pool);
base = SegBase(seg);
if (SegBuffer(seg) != NULL) {
if (SegBuffer(&buffer, seg)) {
/* We use BufferGetInit here (and not BufferScanLimit) because we
* want to be able to find objects that have been allocated and
* committed since the last flip. These objects lie between the
@ -1917,7 +1912,7 @@ static Res AMCAddrObject(Addr *pReturn, Pool pool, Seg seg, Addr addr)
* *must* point inside a live object and we stop skipping once we
* have found it. The init pointer serves this purpose.
*/
limit = BufferGetInit(SegBuffer(seg));
limit = BufferGetInit(buffer);
} else {
limit = SegLimit(seg);
}
@ -1969,24 +1964,22 @@ static Size AMCFreeSize(Pool pool)
*
* See <design/poolamc/#describe>.
*/
static Res AMCDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res AMCDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Res res;
Pool pool = CouldBeA(AbstractPool, inst);
AMC amc = CouldBeA(AMCZPool, pool);
Res res;
Ring node, nextNode;
const char *rampmode;
if(!TESTC(AMCZPool, amc))
if (!TESTC(AMCZPool, amc))
return ResPARAM;
if(stream == NULL)
if (stream == NULL)
return ResPARAM;
res = WriteF(stream, depth,
(amc->rankSet == RankSetEMPTY) ? "AMCZ" : "AMC",
" $P {\n", (WriteFP)amc, " pool $P ($U)\n",
(WriteFP)pool, (WriteFU)pool->serial,
NULL);
if(res != ResOK)
res = NextMethod(Inst, AMCZPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
switch(amc->rampMode) {
@ -2013,20 +2006,16 @@ static Res AMCDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
return res;
}
if(0) {
if (0) {
/* SegDescribes */
RING_FOR(node, &pool->segRing, nextNode) {
Seg seg = RING_ELT(Seg, poolRing, node);
res = AMCSegDescribe(seg, stream, depth + 2);
res = SegDescribe(seg, stream, depth + 2);
if(res != ResOK)
return res;
}
}
res = WriteF(stream, depth, "} AMC $P\n", (WriteFP)amc, NULL);
if(res != ResOK)
return res;
return ResOK;
}
@ -2038,11 +2027,12 @@ DEFINE_CLASS(Pool, AMCZPool, klass)
INHERIT_CLASS(klass, AMCZPool, AbstractSegBufPool);
PoolClassMixInFormat(klass);
PoolClassMixInCollect(klass);
klass->instClassStruct.describe = AMCDescribe;
klass->instClassStruct.finish = AMCFinish;
klass->size = sizeof(AMCStruct);
klass->attr |= AttrMOVINGGC;
klass->varargs = AMCVarargs;
klass->init = AMCZInit;
klass->finish = AMCFinish;
klass->bufferFill = AMCBufferFill;
klass->bufferEmpty = AMCBufferEmpty;
klass->whiten = AMCWhiten;
@ -2056,7 +2046,6 @@ DEFINE_CLASS(Pool, AMCZPool, klass)
klass->bufferClass = amcBufClassGet;
klass->totalSize = AMCTotalSize;
klass->freeSize = AMCFreeSize;
klass->describe = AMCDescribe;
}

202
mps/code/poolams.c
View file

@ -260,7 +260,7 @@ static Res AMSSegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
return ResOK;
failCreateTables:
NextMethod(Seg, AMSSeg, finish)(seg);
NextMethod(Inst, AMSSeg, finish)(MustBeA(Inst, seg));
failNextMethod:
AVER(res != ResOK);
return res;
@ -269,19 +269,15 @@ failNextMethod:
/* AMSSegFinish -- Finish method for AMS segments */
static void AMSSegFinish(Seg seg)
static void AMSSegFinish(Inst inst)
{
AMSSeg amsseg;
AMS ams;
Arena arena;
Seg seg = MustBeA(Seg, inst);
AMSSeg amsseg = MustBeA(AMSSeg, seg);
AMS ams = amsseg->ams;
Arena arena = PoolArena(AMSPool(ams));
AVERT(Seg, seg);
amsseg = Seg2AMSSeg(seg);
AVERT(AMSSeg, amsseg);
ams = amsseg->ams;
AVERT(AMS, ams);
arena = PoolArena(AMSPool(ams));
AVER(SegBuffer(seg) == NULL);
AVER(!SegHasBuffer(seg));
/* keep the destructions in step with AMSSegInit failure cases */
amsDestroyTables(ams, amsseg->allocTable, amsseg->nongreyTable,
@ -290,7 +286,7 @@ static void AMSSegFinish(Seg seg)
amsseg->sig = SigInvalid;
/* finish the superclass fields last */
NextMethod(Seg, AMSSeg, finish)(seg);
NextMethod(Inst, AMSSeg, finish)(inst);
}
@ -498,44 +494,42 @@ failCreateTablesLo:
/* AMSSegDescribe -- describe an AMS segment */
#define WRITE_BUFFER_LIMIT(stream, seg, i, buffer, accessor, code) \
#define WRITE_BUFFER_LIMIT(i, accessor, code) \
BEGIN \
if ((buffer) != NULL \
&& (i) == AMS_ADDR_INDEX(seg, accessor(buffer))) { \
if (hasBuffer && (i) == AMS_ADDR_INDEX(seg, accessor(buffer))) { \
Res _res = WriteF(stream, 0, code, NULL); \
if (_res != ResOK) return _res; \
} \
END
static Res AMSSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
static Res AMSSegDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
AMSSeg amsseg = CouldBeA(AMSSeg, inst);
Seg seg = CouldBeA(Seg, amsseg);
Res res;
AMSSeg amsseg;
Buffer buffer; /* the segment's buffer, if it has one */
Buffer buffer;
Bool hasBuffer;
Index i;
if (!TESTT(Seg, seg))
return ResFAIL;
if (!TESTC(AMSSeg, amsseg))
return ResPARAM;
if (stream == NULL)
return ResFAIL;
amsseg = Seg2AMSSeg(seg);
if (!TESTT(AMSSeg, amsseg))
return ResFAIL;
return ResPARAM;
/* Describe the superclass fields first via next-method call */
res = NextMethod(Seg, AMSSeg, describe)(seg, stream, depth);
res = NextMethod(Inst, AMSSeg, describe)(inst, stream, depth);
if (res != ResOK)
return res;
buffer = SegBuffer(seg);
hasBuffer = SegBuffer(&buffer, seg);
res = WriteF(stream, depth,
" AMS $P\n", (WriteFP)amsseg->ams,
" grains $W\n", (WriteFW)amsseg->grains,
" freeGrains $W\n", (WriteFW)amsseg->freeGrains,
" buffferedGrains $W\n", (WriteFW)amsseg->bufferedGrains,
" newGrains $W\n", (WriteFW)amsseg->newGrains,
" oldGrains $W\n", (WriteFW)amsseg->oldGrains,
res = WriteF(stream, depth + 2,
"AMS $P\n", (WriteFP)amsseg->ams,
"grains $W\n", (WriteFW)amsseg->grains,
"freeGrains $W\n", (WriteFW)amsseg->freeGrains,
"buffferedGrains $W\n", (WriteFW)amsseg->bufferedGrains,
"newGrains $W\n", (WriteFW)amsseg->newGrains,
"oldGrains $W\n", (WriteFW)amsseg->oldGrains,
NULL);
if (res != ResOK)
return res;
@ -570,9 +564,9 @@ static Res AMSSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
return res;
}
WRITE_BUFFER_LIMIT(stream, seg, i, buffer, BufferBase, "[");
WRITE_BUFFER_LIMIT(stream, seg, i, buffer, BufferGetInit, "|");
WRITE_BUFFER_LIMIT(stream, seg, i, buffer, BufferAlloc, ">");
WRITE_BUFFER_LIMIT(i, BufferBase, "[");
WRITE_BUFFER_LIMIT(i, BufferGetInit, "|");
WRITE_BUFFER_LIMIT(i, BufferAlloc, ">");
if (AMS_ALLOCED(seg, i)) {
if (amsseg->colourTablesInUse) {
@ -592,8 +586,8 @@ static Res AMSSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
if (res != ResOK)
return res;
WRITE_BUFFER_LIMIT(stream, seg, i+1, buffer, BufferScanLimit, "<");
WRITE_BUFFER_LIMIT(stream, seg, i+1, buffer, BufferLimit, "]");
WRITE_BUFFER_LIMIT(i+1, BufferScanLimit, "<");
WRITE_BUFFER_LIMIT(i+1, BufferLimit, "]");
}
return ResOK;
@ -605,12 +599,12 @@ static Res AMSSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
DEFINE_CLASS(Seg, AMSSeg, klass)
{
INHERIT_CLASS(klass, AMSSeg, GCSeg);
klass->instClassStruct.describe = AMSSegDescribe;
klass->instClassStruct.finish = AMSSegFinish;
klass->size = sizeof(AMSSegStruct);
klass->init = AMSSegInit;
klass->finish = AMSSegFinish;
klass->merge = AMSSegMerge;
klass->split = AMSSegSplit;
klass->describe = AMSSegDescribe;
AVERT(SegClass, klass);
}
@ -707,7 +701,7 @@ static void AMSSegsDestroy(AMS ams)
RING_FOR(node, ring, next) {
Seg seg = SegOfPoolRing(node);
AMSSeg amsseg = Seg2AMSSeg(seg);
AVER(SegBuffer(seg) == NULL);
AVER(!SegHasBuffer(seg));
AVERT(AMSSeg, amsseg);
AVER(amsseg->ams == ams);
AVER(amsseg->bufferedGrains == 0);
@ -813,7 +807,7 @@ static Res AMSInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
return ResOK;
failGenInit:
PoolAbsFinish(pool);
NextMethod(Inst, AMSPool, finish)(MustBeA(Inst, pool));
failAbsInit:
return res;
}
@ -824,12 +818,11 @@ failAbsInit:
* Destroys all the segs in the pool. Can't invalidate the AMS until
* we've destroyed all the segments, as it may be checked.
*/
void AMSFinish(Pool pool)
void AMSFinish(Inst inst)
{
AMS ams;
Pool pool = MustBeA(AbstractPool, inst);
AMS ams = MustBeA(AMSPool, pool);
AVERT(Pool, pool);
ams = PoolAMS(pool);
AVERT(AMS, ams);
ams->segsDestroy(ams);
@ -837,7 +830,8 @@ void AMSFinish(Pool pool)
ams->sig = SigInvalid;
PoolGenFinish(ams->pgen);
ams->pgen = NULL;
PoolAbsFinish(pool);
NextMethod(Inst, AMSPool, finish)(inst);
}
@ -938,7 +932,7 @@ static Res AMSBufferFill(Addr *baseReturn, Addr *limitReturn,
AVERT_CRITICAL(AMSSeg, amsseg);
if (amsseg->freeGrains >= AMSGrains(ams, size)) {
if (SegRankSet(seg) == rankSet
&& SegBuffer(seg) == NULL
&& !SegHasBuffer(seg)
/* Can't use a white or grey segment, see d.m.p.fill.colour. */
&& SegWhite(seg) == TraceSetEMPTY
&& SegGrey(seg) == TraceSetEMPTY)
@ -1113,8 +1107,7 @@ static Res AMSWhiten(Pool pool, Trace trace, Seg seg)
amsseg->allocTableInUse = TRUE;
}
buffer = SegBuffer(seg);
if (buffer != NULL) { /* <design/poolams/#condemn.buffer> */
if (SegBuffer(&buffer, seg)) { /* <design/poolams/#condemn.buffer> */
Index scanLimitIndex, limitIndex;
scanLimitIndex = AMS_ADDR_INDEX(seg, BufferScanLimit(buffer));
limitIndex = AMS_ADDR_INDEX(seg, BufferLimit(buffer));
@ -1181,6 +1174,7 @@ static Res amsIterate(Seg seg, AMSObjectFunction f, void *closure)
Index i;
Addr p, next, limit;
Buffer buffer;
Bool hasBuffer;
AVERT(Seg, seg);
AVERT(AMSObjectFunction, f);
@ -1200,16 +1194,15 @@ static Res amsIterate(Seg seg, AMSObjectFunction f, void *closure)
p = SegBase(seg);
limit = SegLimit(seg);
buffer = SegBuffer(seg);
hasBuffer = SegBuffer(&buffer, seg);
while (p < limit) { /* loop over the objects in the segment */
if (buffer != NULL
&& p == BufferScanLimit(buffer) && p != BufferLimit(buffer)) {
if (hasBuffer && p == BufferScanLimit(buffer) && p != BufferLimit(buffer)) {
/* skip buffer */
next = BufferLimit(buffer);
AVER(AddrIsAligned(next, alignment));
} else {
AVER((buffer == NULL)
AVER(!hasBuffer
|| (p < BufferScanLimit(buffer))
|| (p >= BufferLimit(buffer))); /* not in the buffer */
@ -1464,7 +1457,7 @@ static Res AMSFix(Pool pool, ScanState ss, Seg seg, Ref *refIO)
case RankFINAL:
case RankWEAK:
AVER_CRITICAL(AddrIsAligned(base, PoolAlignment(pool)));
AVER_CRITICAL(AMS_ALLOCED(seg, i));
AVER_CRITICAL(AMS_ALLOCED(seg, i)); /* <design/check/#.common> */
if (AMS_IS_WHITE(seg, i)) {
ss->wasMarked = FALSE;
if (ss->rank == RankWEAK) { /* then splat the reference */
@ -1607,7 +1600,7 @@ static void AMSReclaim(Pool pool, Trace trace, Seg seg)
amsseg->colourTablesInUse = FALSE;
SegSetWhite(seg, TraceSetDel(SegWhite(seg), trace));
if (amsseg->freeGrains == grains && SegBuffer(seg) == NULL) {
if (amsseg->freeGrains == grains && !SegHasBuffer(seg)) {
/* No survivors */
AVER(amsseg->bufferedGrains == 0);
PoolGenFree(ams->pgen, seg,
@ -1619,6 +1612,66 @@ static void AMSReclaim(Pool pool, Trace trace, Seg seg)
}
/* AMSWalk -- walk formatted objects in AMC pool */
static void AMSWalk(Pool pool, Seg seg, FormattedObjectsVisitor f,
void *p, size_t s)
{
AMS ams;
AMSSeg amsseg;
Addr object, base, limit;
Format format;
AVERT(Pool, pool);
AVERT(Seg, seg);
AVER(FUNCHECK(f));
/* p and s are arbitrary closures and can't be checked */
ams = PoolAMS(pool);
AVERT(AMS, ams);
amsseg = Seg2AMSSeg(seg);
AVERT(AMSSeg, amsseg);
format = pool->format;
base = SegBase(seg);
object = base;
limit = SegLimit(seg);
while (object < limit) {
/* object is a slight misnomer because it might point to a free grain */
Addr next;
Index i;
Buffer buffer;
if (SegBuffer(&buffer, seg)) {
if (object == BufferScanLimit(buffer)
&& BufferScanLimit(buffer) != BufferLimit(buffer)) {
/* skip over buffered area */
object = BufferLimit(buffer);
continue;
}
/* since we skip over the buffered area we are always */
/* either before the buffer, or after it, never in it */
AVER(object < BufferGetInit(buffer) || BufferLimit(buffer) <= object);
}
i = AMS_ADDR_INDEX(seg, object);
if (!AMS_ALLOCED(seg, i)) {
/* This grain is free */
object = AddrAdd(object, PoolAlignment(pool));
continue;
}
object = AddrAdd(object, format->headerSize);
next = format->skip(object);
next = AddrSub(next, format->headerSize);
AVER(AddrIsAligned(next, PoolAlignment(pool)));
if (!amsseg->colourTablesInUse || !AMS_IS_WHITE(seg, i))
(*f)(object, pool->format, pool, p, s);
object = next;
}
}
/* AMSFreeWalk -- free block walking method of the pool class */
static void AMSFreeWalk(Pool pool, FreeBlockVisitor f, void *p)
@ -1669,25 +1722,25 @@ static Size AMSFreeSize(Pool pool)
*
* Iterates over the segments, describing all of them.
*/
static Res AMSDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res AMSDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
AMS ams;
Pool pool = CouldBeA(AbstractPool, inst);
AMS ams = CouldBeA(AMSPool, pool);
Ring ring, node, nextNode;
Res res;
if (!TESTT(Pool, pool))
return ResFAIL;
ams = PoolAMS(pool);
if (!TESTT(AMS, ams))
return ResFAIL;
if (!TESTC(AMSPool, ams))
return ResPARAM;
if (stream == NULL)
return ResFAIL;
return ResPARAM;
res = WriteF(stream, depth,
"AMS $P {\n", (WriteFP)ams,
" pool $P ($U)\n",
(WriteFP)pool, (WriteFU)pool->serial,
" grain shift $U\n", (WriteFU)ams->grainShift,
res = NextMethod(Inst, AMSPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2,
"grain shift $U\n", (WriteFU)ams->grainShift,
NULL);
if (res != ResOK)
return res;
@ -1706,10 +1759,6 @@ static Res AMSDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
return res;
}
res = WriteF(stream, depth, "} AMS $P\n",(WriteFP)ams, NULL);
if (res != ResOK)
return res;
return ResOK;
}
@ -1723,10 +1772,11 @@ DEFINE_CLASS(Pool, AMSPool, klass)
{
INHERIT_CLASS(klass, AMSPool, AbstractCollectPool);
PoolClassMixInFormat(klass);
klass->instClassStruct.describe = AMSDescribe;
klass->instClassStruct.finish = AMSFinish;
klass->size = sizeof(AMSStruct);
klass->varargs = AMSVarargs;
klass->init = AMSInit;
klass->finish = AMSFinish;
klass->bufferClass = RankBufClassGet;
klass->bufferFill = AMSBufferFill;
klass->bufferEmpty = AMSBufferEmpty;
@ -1736,12 +1786,10 @@ DEFINE_CLASS(Pool, AMSPool, klass)
klass->fix = AMSFix;
klass->fixEmergency = AMSFix;
klass->reclaim = AMSReclaim;
/* TODO: job003738. See also impl.c.pool.check.ams.walk. */
klass->walk = PoolNoWalk;
klass->walk = AMSWalk;
klass->freewalk = AMSFreeWalk;
klass->totalSize = AMSTotalSize;
klass->freeSize = AMSFreeSize;
klass->describe = AMSDescribe;
AVERT(PoolClass, klass);
}

2
mps/code/poolams.h
View file

@ -169,7 +169,7 @@ typedef struct AMSSegStruct {
extern Res AMSInitInternal(AMS ams, Arena arena, PoolClass klass,
Chain chain, unsigned gen,
Bool shareAllocTable, ArgList args);
extern void AMSFinish(Pool pool);
extern void AMSFinish(Inst inst);
extern Bool AMSCheck(AMS ams);
extern Res AMSScan(Bool *totalReturn, ScanState ss, Pool pool, Seg seg);

47
mps/code/poolawl.c
View file

@ -240,7 +240,7 @@ failControlAllocAlloc:
failControlAllocScanned:
ControlFree(arena, awlseg->mark, tableSize);
failControlAllocMark:
NextMethod(Seg, AWLSeg, finish)(seg);
NextMethod(Inst, AWLSeg, finish)(MustBeA(Inst, seg));
failSuperInit:
AVER(res != ResOK);
return res;
@ -249,8 +249,9 @@ failSuperInit:
/* AWLSegFinish -- Finish method for AWL segments */
static void AWLSegFinish(Seg seg)
static void AWLSegFinish(Inst inst)
{
Seg seg = MustBeA(Seg, inst);
AWLSeg awlseg = MustBeA(AWLSeg, seg);
Pool pool = SegPool(seg);
AWL awl = MustBeA(AWLPool, pool);
@ -269,7 +270,7 @@ static void AWLSegFinish(Seg seg)
awlseg->sig = SigInvalid;
/* finish the superclass fields last */
NextMethod(Seg, AWLSeg, finish)(seg);
NextMethod(Inst, AWLSeg, finish)(inst);
}
@ -279,9 +280,9 @@ DEFINE_CLASS(Seg, AWLSeg, klass)
{
INHERIT_CLASS(klass, AWLSeg, GCSeg);
SegClassMixInNoSplitMerge(klass); /* no support for this (yet) */
klass->instClassStruct.finish = AWLSegFinish;
klass->size = sizeof(AWLSegStruct);
klass->init = AWLSegInit;
klass->finish = AWLSegFinish;
}
@ -571,7 +572,7 @@ static Res AWLInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
return ResOK;
failGenInit:
PoolAbsFinish(pool);
NextMethod(Inst, AWLPool, finish)(MustBeA(Inst, pool));
failAbsInit:
AVER(res != ResOK);
return res;
@ -580,8 +581,9 @@ failAbsInit:
/* AWLFinish -- finish an AWL pool */
static void AWLFinish(Pool pool)
static void AWLFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
AWL awl = MustBeA(AWLPool, pool);
Ring ring, node, nextNode;
@ -589,7 +591,7 @@ static void AWLFinish(Pool pool)
RING_FOR(node, ring, nextNode) {
Seg seg = SegOfPoolRing(node);
AWLSeg awlseg = MustBeA(AWLSeg, seg);
AVER(SegBuffer(seg) == NULL);
AVER(!SegHasBuffer(seg));
AVERT(AWLSeg, awlseg);
AVER(awlseg->bufferedGrains == 0);
PoolGenFree(awl->pgen, seg,
@ -600,7 +602,8 @@ static void AWLFinish(Pool pool)
}
awl->sig = SigInvalid;
PoolGenFinish(awl->pgen);
PoolAbsFinish(pool);
NextMethod(Inst, AWLPool, finish)(inst);
}
@ -627,7 +630,7 @@ static Res AWLBufferFill(Addr *baseReturn, Addr *limitReturn,
/* Only try to allocate in the segment if it is not already */
/* buffered, and has the same ranks as the buffer. */
if (SegBuffer(seg) == NULL
if (!SegHasBuffer(seg)
&& SegRankSet(seg) == BufferRankSet(buffer)
&& AWLGrainsSize(awl, awlseg->freeGrains) >= size
&& AWLSegAlloc(&base, &limit, awlseg, awl, size))
@ -715,7 +718,7 @@ static Res AWLWhiten(Pool pool, Trace trace, Seg seg)
{
AWL awl = MustBeA(AWLPool, pool);
AWLSeg awlseg = MustBeA(AWLSeg, seg);
Buffer buffer = SegBuffer(seg);
Buffer buffer;
Count agedGrains, uncondemnedGrains;
/* All parameters checked by generic PoolWhiten. */
@ -724,7 +727,7 @@ static Res AWLWhiten(Pool pool, Trace trace, Seg seg)
/* see <design/poolawl/#fun.condemn> */
AVER(SegWhite(seg) == TraceSetEMPTY);
if(buffer == NULL) {
if (!SegBuffer(&buffer, seg)) {
awlRangeWhiten(awlseg, 0, awlseg->grains);
uncondemnedGrains = (Count)0;
} else {
@ -781,6 +784,8 @@ static void AWLRangeGrey(AWLSeg awlseg, Index base, Index limit)
static void AWLGrey(Pool pool, Trace trace, Seg seg)
{
Buffer buffer;
AVERT(Pool, pool);
AVERT(Trace, trace);
AVERT(Seg, seg);
@ -790,9 +795,8 @@ static void AWLGrey(Pool pool, Trace trace, Seg seg)
AWLSeg awlseg = MustBeA(AWLSeg, seg);
SegSetGrey(seg, TraceSetAdd(SegGrey(seg), trace));
if (SegBuffer(seg) != NULL) {
if (SegBuffer(&buffer, seg)) {
Addr base = SegBase(seg);
Buffer buffer = SegBuffer(seg);
AWLRangeGrey(awlseg,
0,
@ -866,7 +870,7 @@ static Res awlScanSinglePass(Bool *anyScannedReturn,
AWL awl = MustBeA(AWLPool, pool);
AWLSeg awlseg = MustBeA(AWLSeg, seg);
Arena arena = PoolArena(pool);
Buffer buffer = SegBuffer(seg);
Buffer buffer;
Format format = pool->format;
Addr base = SegBase(seg);
Addr limit = SegLimit(seg);
@ -879,7 +883,7 @@ static Res awlScanSinglePass(Bool *anyScannedReturn,
*anyScannedReturn = FALSE;
p = base;
if (buffer != NULL && BufferScanLimit(buffer) != BufferLimit(buffer))
if (SegBuffer(&buffer, seg) && BufferScanLimit(buffer) != BufferLimit(buffer))
bufferScanLimit = BufferScanLimit(buffer);
else
bufferScanLimit = limit;
@ -1027,7 +1031,8 @@ static void AWLReclaim(Pool pool, Trace trace, Seg seg)
AWL awl = MustBeA(AWLPool, pool);
AWLSeg awlseg = MustBeA(AWLSeg, seg);
Addr base = SegBase(seg);
Buffer buffer = SegBuffer(seg);
Buffer buffer;
Bool hasBuffer = SegBuffer(&buffer, seg);
Format format = pool->format;
Count reclaimedGrains = (Count)0;
Count preservedInPlaceCount = (Count)0;
@ -1046,7 +1051,7 @@ static void AWLReclaim(Pool pool, Trace trace, Seg seg)
continue;
}
p = awlAddrOfIndex(base, awl, i);
if (buffer != NULL
if (hasBuffer
&& p == BufferScanLimit(buffer)
&& BufferScanLimit(buffer) != BufferLimit(buffer))
{
@ -1085,7 +1090,7 @@ static void AWLReclaim(Pool pool, Trace trace, Seg seg)
trace->preservedInPlaceSize += preservedInPlaceSize;
SegSetWhite(seg, TraceSetDel(SegWhite(seg), trace));
if (awlseg->freeGrains == awlseg->grains && buffer == NULL) {
if (awlseg->freeGrains == awlseg->grains && !hasBuffer) {
/* No survivors */
AVER(awlseg->bufferedGrains == 0);
PoolGenFree(awl->pgen, seg,
@ -1158,9 +1163,9 @@ static void AWLWalk(Pool pool, Seg seg, FormattedObjectsVisitor f,
/* free grain */
Addr next;
Index i;
Buffer buffer;
if (SegBuffer(seg) != NULL) {
Buffer buffer = SegBuffer(seg);
if (SegBuffer(&buffer, seg)) {
if (object == BufferScanLimit(buffer)
&& BufferScanLimit(buffer) != BufferLimit(buffer)) {
/* skip over buffered area */
@ -1214,10 +1219,10 @@ DEFINE_CLASS(Pool, AWLPool, klass)
{
INHERIT_CLASS(klass, AWLPool, AbstractCollectPool);
PoolClassMixInFormat(klass);
klass->instClassStruct.finish = AWLFinish;
klass->size = sizeof(AWLPoolStruct);
klass->varargs = AWLVarargs;
klass->init = AWLInit;
klass->finish = AWLFinish;
klass->bufferClass = RankBufClassGet;
klass->bufferFill = AWLBufferFill;
klass->bufferEmpty = AWLBufferEmpty;

37
mps/code/poollo.c
View file

@ -61,7 +61,7 @@ typedef struct LOSegStruct {
/* forward decls */
static Res loSegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args);
static void loSegFinish(Seg seg);
static void loSegFinish(Inst inst);
static Count loSegGrains(LOSeg loseg);
@ -71,9 +71,9 @@ DEFINE_CLASS(Seg, LOSeg, klass)
{
INHERIT_CLASS(klass, LOSeg, GCSeg);
SegClassMixInNoSplitMerge(klass);
klass->instClassStruct.finish = loSegFinish;
klass->size = sizeof(LOSegStruct);
klass->init = loSegInit;
klass->finish = loSegFinish;
}
@ -143,7 +143,7 @@ static Res loSegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
failAllocTable:
ControlFree(arena, loseg->mark, tablebytes);
failMarkTable:
NextMethod(Seg, LOSeg, finish)(seg);
NextMethod(Inst, LOSeg, finish)(MustBeA(Inst, seg));
failSuperInit:
AVER(res != ResOK);
return res;
@ -152,8 +152,9 @@ failSuperInit:
/* loSegFinish -- Finish method for LO segments */
static void loSegFinish(Seg seg)
static void loSegFinish(Inst inst)
{
Seg seg = MustBeA(Seg, inst);
LOSeg loseg = MustBeA(LOSeg, seg);
Pool pool = SegPool(seg);
Arena arena = PoolArena(pool);
@ -167,7 +168,7 @@ static void loSegFinish(Seg seg)
ControlFree(arena, loseg->alloc, tablesize);
ControlFree(arena, loseg->mark, tablesize);
NextMethod(Seg, LOSeg, finish)(seg);
NextMethod(Inst, LOSeg, finish)(inst);
}
@ -231,7 +232,7 @@ static Bool loSegFindFree(Addr *bReturn, Addr *lReturn,
AVER(agrains <= loseg->freeGrains);
AVER(size <= SegSize(seg));
if(SegBuffer(seg) != NULL)
if (SegHasBuffer(seg))
/* Don't bother trying to allocate from a buffered segment */
return FALSE;
@ -312,11 +313,12 @@ static void loSegReclaim(LOSeg loseg, Trace trace)
*/
p = base;
while(p < limit) {
Buffer buffer = SegBuffer(seg);
Buffer buffer;
Bool hasBuffer = SegBuffer(&buffer, seg);
Addr q;
Index i;
if(buffer != NULL) {
if (hasBuffer) {
marked = TRUE;
if (p == BufferScanLimit(buffer)
&& BufferScanLimit(buffer) != BufferLimit(buffer)) {
@ -403,9 +405,9 @@ static void LOWalk(Pool pool, Seg seg, FormattedObjectsVisitor f,
Addr object = loAddrOfIndex(base, lo, i);
Addr next;
Index j;
Buffer buffer;
if(SegBuffer(seg) != NULL) {
Buffer buffer = SegBuffer(seg);
if (SegBuffer(&buffer, seg)) {
if(object == BufferScanLimit(buffer) &&
BufferScanLimit(buffer) != BufferLimit(buffer)) {
/* skip over buffered area */
@ -501,7 +503,7 @@ static Res LOInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
return ResOK;
failGenInit:
PoolAbsFinish(pool);
NextMethod(Inst, LOPool, finish)(MustBeA(Inst, pool));
failAbsInit:
AVER(res != ResOK);
return res;
@ -510,15 +512,16 @@ failAbsInit:
/* LOFinish -- finish an LO pool */
static void LOFinish(Pool pool)
static void LOFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
LO lo = MustBeA(LOPool, pool);
Ring node, nextNode;
RING_FOR(node, &pool->segRing, nextNode) {
Seg seg = SegOfPoolRing(node);
LOSeg loseg = MustBeA(LOSeg, seg);
AVER(SegBuffer(seg) == NULL);
AVER(!SegHasBuffer(seg));
AVERT(LOSeg, loseg);
AVER(loseg->bufferedGrains == 0);
PoolGenFree(lo->pgen, seg,
@ -530,7 +533,8 @@ static void LOFinish(Pool pool)
PoolGenFinish(lo->pgen);
lo->sig = SigInvalid;
PoolAbsFinish(pool);
NextMethod(Inst, LOPool, finish)(inst);
}
@ -658,8 +662,7 @@ static Res LOWhiten(Pool pool, Trace trace, Seg seg)
grains = loSegGrains(loseg);
/* Whiten allocated objects; leave free areas black. */
buffer = SegBuffer(seg);
if (buffer != NULL) {
if (SegBuffer(&buffer, seg)) {
Addr base = SegBase(seg);
Index scanLimitIndex = loIndexOfAddr(base, lo, BufferScanLimit(buffer));
Index limitIndex = loIndexOfAddr(base, lo, BufferLimit(buffer));
@ -783,10 +786,10 @@ DEFINE_CLASS(Pool, LOPool, klass)
INHERIT_CLASS(klass, LOPool, AbstractSegBufPool);
PoolClassMixInFormat(klass);
PoolClassMixInCollect(klass);
klass->instClassStruct.finish = LOFinish;
klass->size = sizeof(LOStruct);
klass->varargs = LOVarargs;
klass->init = LOInit;
klass->finish = LOFinish;
klass->bufferFill = LOBufferFill;
klass->bufferEmpty = LOBufferEmpty;
klass->whiten = LOWhiten;

43
mps/code/poolmfs.c
View file

@ -1,7 +1,7 @@
/* poolmfs.c: MANUAL FIXED SMALL UNIT POOL
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* This is the implementation of the MFS pool class.
*
@ -39,10 +39,6 @@
SRCID(poolmfs, "$Id$");
typedef MFS MFSPool;
DECLARE_CLASS(Pool, MFSPool, AbstractPool);
/* ROUND -- Round up
*
* Rounds n up to the nearest multiple of unit.
@ -153,14 +149,16 @@ static void MFSTractFreeVisitor(Pool pool, Addr base, Size size,
}
static void MFSFinish(Pool pool)
static void MFSFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
MFS mfs = MustBeA(MFSPool, pool);
MFSFinishTracts(pool, MFSTractFreeVisitor, UNUSED_POINTER);
mfs->sig = SigInvalid;
PoolAbsFinish(pool);
NextMethod(Inst, MFSPool, finish)(inst);
}
@ -306,8 +304,9 @@ static Size MFSFreeSize(Pool pool)
}
static Res MFSDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res MFSDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Pool pool = CouldBeA(AbstractPool, inst);
MFS mfs = CouldBeA(MFSPool, pool);
Res res;
@ -316,35 +315,35 @@ static Res MFSDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
if (stream == NULL)
return ResPARAM;
res = WriteF(stream, depth,
"unroundedUnitSize $W\n", (WriteFW)mfs->unroundedUnitSize,
"extendBy $W\n", (WriteFW)mfs->extendBy,
"extendSelf $S\n", WriteFYesNo(mfs->extendSelf),
"unitSize $W\n", (WriteFW)mfs->unitSize,
"freeList $P\n", (WriteFP)mfs->freeList,
"total $W\n", (WriteFW)mfs->total,
"free $W\n", (WriteFW)mfs->free,
"tractList $P\n", (WriteFP)mfs->tractList,
NULL);
res = NextMethod(Inst, MFSPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
return ResOK;
return WriteF(stream, depth + 2,
"unroundedUnitSize $W\n", (WriteFW)mfs->unroundedUnitSize,
"extendBy $W\n", (WriteFW)mfs->extendBy,
"extendSelf $S\n", WriteFYesNo(mfs->extendSelf),
"unitSize $W\n", (WriteFW)mfs->unitSize,
"freeList $P\n", (WriteFP)mfs->freeList,
"total $W\n", (WriteFW)mfs->total,
"free $W\n", (WriteFW)mfs->free,
"tractList $P\n", (WriteFP)mfs->tractList,
NULL);
}
DEFINE_CLASS(Pool, MFSPool, klass)
{
INHERIT_CLASS(klass, MFSPool, AbstractPool);
klass->instClassStruct.describe = MFSDescribe;
klass->instClassStruct.finish = MFSFinish;
klass->size = sizeof(MFSStruct);
klass->varargs = MFSVarargs;
klass->init = MFSInit;
klass->finish = MFSFinish;
klass->alloc = MFSAlloc;
klass->free = MFSFree;
klass->totalSize = MFSTotalSize;
klass->freeSize = MFSFreeSize;
klass->describe = MFSDescribe;
}
@ -386,7 +385,7 @@ Bool MFSCheck(MFS mfs)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

6
mps/code/poolmfs.h
View file

@ -2,7 +2,7 @@
*
* $Id$
*
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* The MFS pool is used to manage small fixed-size chunks of memory. It
* stores control structures in the memory it manages, rather than to one
@ -32,6 +32,8 @@
#include "mpscmfs.h"
typedef struct MFSStruct *MFS;
typedef MFS MFSPool;
DECLARE_CLASS(Pool, MFSPool, AbstractPool);
#define MFSPool(mfs) (&(mfs)->poolStruct)
@ -55,7 +57,7 @@ extern void MFSFinishTracts(Pool pool, MFSTractVisitor visitor,
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

32
mps/code/poolmrg.c
View file

@ -637,8 +637,9 @@ static Res MRGInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
/* MRGFinish -- finish a MRG pool */
static void MRGFinish(Pool pool)
static void MRGFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
MRG mrg = MustBeA(MRGPool, pool);
Ring node, nextNode;
@ -676,7 +677,7 @@ static void MRGFinish(Pool pool)
RingFinish(&mrg->refRing);
/* <design/poolmrg/#trans.no-finish> */
PoolAbsFinish(pool);
NextMethod(Inst, MRGPool, finish)(inst);
}
@ -770,8 +771,10 @@ Res MRGDeregister(Pool pool, Ref obj)
* This could be improved by implementing MRGSegDescribe
* and having MRGDescribe iterate over all the pool's segments.
*/
static Res MRGDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res MRGDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Pool pool = CouldBeA(AbstractPool, inst);
MRG mrg = CouldBeA(MRGPool, pool);
Arena arena;
Ring node, nextNode;
@ -783,20 +786,25 @@ static Res MRGDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
if (stream == NULL)
return ResPARAM;
res = NextMethod(Inst, MRGPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2, "extendBy $W\n", (WriteFW)mrg->extendBy, NULL);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2, "Entry queue:\n", NULL);
if (res != ResOK)
return res;
arena = PoolArena(pool);
res = WriteF(stream, depth, "extendBy $W\n", (WriteFW)mrg->extendBy, NULL);
if (res != ResOK)
return res;
res = WriteF(stream, depth, "Entry queue:\n", NULL);
if (res != ResOK)
return res;
RING_FOR(node, &mrg->entryRing, nextNode) {
Bool outsideShield = !ArenaShield(arena)->inside;
refPart = MRGRefPartOfLink(linkOfRing(node), arena);
if (outsideShield) {
ShieldEnter(arena);
}
res = WriteF(stream, depth, "at $A Ref $A\n",
res = WriteF(stream, depth + 2, "at $A Ref $A\n",
(WriteFA)refPart, (WriteFA)MRGRefPartRef(arena, refPart),
NULL);
if (outsideShield) {
@ -834,13 +842,13 @@ static Res MRGScan(Bool *totalReturn, ScanState ss, Pool pool, Seg seg)
DEFINE_CLASS(Pool, MRGPool, klass)
{
INHERIT_CLASS(klass, MRGPool, AbstractPool);
klass->instClassStruct.describe = MRGDescribe;
klass->instClassStruct.finish = MRGFinish;
klass->size = sizeof(MRGStruct);
klass->init = MRGInit;
klass->finish = MRGFinish;
klass->grey = PoolTrivGrey;
klass->blacken = PoolTrivBlacken;
klass->scan = MRGScan;
klass->describe = MRGDescribe;
}

76
mps/code/poolmv.c
View file

@ -1,7 +1,7 @@
/* poolmv.c: MANUAL VARIABLE POOL
*
* $Id$
* Copyright (c) 2001-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*
* **** RESTRICTION: This pool may not allocate from the arena control
@ -305,21 +305,20 @@ static Res MVInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
failSpanPoolInit:
PoolFinish(mvBlockPool(mv));
failBlockPoolInit:
PoolAbsFinish(pool);
NextMethod(Inst, MVPool, finish)(MustBeA(Inst, pool));
return res;
}
/* MVFinish -- finish method for class MV */
static void MVFinish(Pool pool)
static void MVFinish(Inst inst)
{
MV mv;
Pool pool = MustBeA(AbstractPool, inst);
MV mv = MustBeA(MVPool, pool);
Ring spans, node = NULL, nextNode; /* gcc whinge stop */
MVSpan span;
AVERT(Pool, pool);
mv = PoolMV(pool);
AVERT(MV, mv);
/* Destroy all the spans attached to the pool. */
@ -335,7 +334,7 @@ static void MVFinish(Pool pool)
PoolFinish(mvBlockPool(mv));
PoolFinish(mvSpanPool(mv));
PoolAbsFinish(pool);
NextMethod(Inst, MVPool, finish)(inst);
}
@ -733,44 +732,46 @@ static Size MVTotalSize(Pool pool)
static Size MVFreeSize(Pool pool)
{
MV mv;
Size size = 0;
Ring node, next;
MV mv = MustBeA(MVPool, pool);
AVERT(Pool, pool);
mv = PoolMV(pool);
AVERT(MV, mv);
RING_FOR(node, &mv->spans, next) {
MVSpan span = RING_ELT(MVSpan, spans, node);
AVERT(MVSpan, span);
size += span->free;
#if defined(AVER_AND_CHECK_ALL)
{
Size size = 0;
Ring node, next;
RING_FOR(node, &mv->spans, next) {
MVSpan span = RING_ELT(MVSpan, spans, node);
AVERT(MVSpan, span);
size += span->free;
}
AVER(size == mv->free);
}
#endif
AVER(size == mv->free + mv->lost);
return size;
return mv->free + mv->lost;
}
static Res MVDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res MVDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Pool pool = CouldBeA(AbstractPool, inst);
MV mv = CouldBeA(MVPool, pool);
Res res;
MV mv;
MVSpan span;
Align step;
Size length;
char c;
Ring spans, node = NULL, nextNode; /* gcc whinge stop */
if (!TESTT(Pool, pool))
return ResFAIL;
mv = PoolMV(pool);
if (!TESTT(MV, mv))
return ResFAIL;
if (!TESTC(MVPool, mv))
return ResPARAM;
if (stream == NULL)
return ResFAIL;
return ResPARAM;
res = WriteF(stream, depth,
res = NextMethod(Inst, MVPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2,
"blockPool $P ($U)\n",
(WriteFP)mvBlockPool(mv), (WriteFU)mvBlockPool(mv)->serial,
"spanPool $P ($U)\n",
@ -781,7 +782,8 @@ static Res MVDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
"free $W\n", (WriteFP)mv->free,
"lost $W\n", (WriteFP)mv->lost,
NULL);
if(res != ResOK) return res;
if(res != ResOK)
return res;
step = pool->alignment;
length = 0x40 * step;
@ -791,11 +793,11 @@ static Res MVDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
Addr i, j;
MVBlock block;
span = RING_ELT(MVSpan, spans, node);
res = WriteF(stream, depth, "MVSpan $P {\n", (WriteFP)span, NULL);
res = WriteF(stream, depth + 2, "MVSpan $P {\n", (WriteFP)span, NULL);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2,
res = WriteF(stream, depth + 4,
"span $P\n", (WriteFP)span,
"tract $P\n", (WriteFP)span->tract,
"free $W\n", (WriteFW)span->free,
@ -815,7 +817,7 @@ static Res MVDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
block = span->blocks;
for(i = span->base.base; i < span->limit.limit; i = AddrAdd(i, length)) {
res = WriteF(stream, depth + 2, "$A ", (WriteFA)i, NULL);
res = WriteF(stream, depth + 4, "$A ", (WriteFA)i, NULL);
if (res != ResOK)
return res;
@ -847,7 +849,7 @@ static Res MVDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
if (res != ResOK)
return res;
}
res = WriteF(stream, depth, "} MVSpan $P\n", (WriteFP)span, NULL);
res = WriteF(stream, depth + 2, "} MVSpan $P\n", (WriteFP)span, NULL);
if (res != ResOK)
return res;
}
@ -862,15 +864,15 @@ static Res MVDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
DEFINE_CLASS(Pool, MVPool, klass)
{
INHERIT_CLASS(klass, MVPool, AbstractBufferPool);
klass->instClassStruct.describe = MVDescribe;
klass->instClassStruct.finish = MVFinish;
klass->size = sizeof(MVStruct);
klass->varargs = MVVarargs;
klass->init = MVInit;
klass->finish = MVFinish;
klass->alloc = MVAlloc;
klass->free = MVFree;
klass->totalSize = MVTotalSize;
klass->freeSize = MVFreeSize;
klass->describe = MVDescribe;
}
@ -927,7 +929,7 @@ Bool MVCheck(MV mv)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

94
mps/code/poolmv2.c
View file

@ -1,7 +1,7 @@
/* poolmv2.c: MANUAL VARIABLE-SIZED TEMPORAL POOL
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .purpose: A manual-variable pool designed to take advantage of
* placement according to predicted deathtime.
@ -33,12 +33,12 @@ typedef struct MVTStruct *MVT;
static void MVTVarargs(ArgStruct args[MPS_ARGS_MAX], va_list varargs);
static Res MVTInit(Pool pool, Arena arena, PoolClass klass, ArgList arg);
static Bool MVTCheck(MVT mvt);
static void MVTFinish(Pool pool);
static void MVTFinish(Inst inst);
static Res MVTBufferFill(Addr *baseReturn, Addr *limitReturn,
Pool pool, Buffer buffer, Size minSize);
static void MVTBufferEmpty(Pool pool, Buffer buffer, Addr base, Addr limit);
static void MVTFree(Pool pool, Addr base, Size size);
static Res MVTDescribe(Pool pool, mps_lib_FILE *stream, Count depth);
static Res MVTDescribe(Inst inst, mps_lib_FILE *stream, Count depth);
static Size MVTTotalSize(Pool pool);
static Size MVTFreeSize(Pool pool);
static Res MVTSegAlloc(Seg *segReturn, MVT mvt, Size size);
@ -139,16 +139,16 @@ typedef struct MVTStruct
DEFINE_CLASS(Pool, MVTPool, klass)
{
INHERIT_CLASS(klass, MVTPool, AbstractBufferPool);
klass->instClassStruct.describe = MVTDescribe;
klass->instClassStruct.finish = MVTFinish;
klass->size = sizeof(MVTStruct);
klass->varargs = MVTVarargs;
klass->init = MVTInit;
klass->finish = MVTFinish;
klass->free = MVTFree;
klass->bufferFill = MVTBufferFill;
klass->bufferEmpty = MVTBufferEmpty;
klass->totalSize = MVTTotalSize;
klass->freeSize = MVTFreeSize;
klass->describe = MVTDescribe;
}
/* Macros */
@ -376,7 +376,7 @@ failFreeLandInit:
failFreeSecondaryInit:
LandFinish(MVTFreePrimary(mvt));
failFreePrimaryInit:
PoolAbsFinish(pool);
NextMethod(Inst, MVTPool, finish)(MustBeA(Inst, pool));
failAbsInit:
AVER(res != ResOK);
return res;
@ -421,18 +421,15 @@ static Bool MVTCheck(MVT mvt)
/* MVTFinish -- finish an MVT pool
*/
static void MVTFinish(Pool pool)
static void MVTFinish(Inst inst)
{
MVT mvt;
Arena arena;
Pool pool = MustBeA(AbstractPool, inst);
MVT mvt = MustBeA(MVTPool, pool);
Arena arena = PoolArena(pool);
Ring ring;
Ring node, nextNode;
AVERT(Pool, pool);
mvt = PoolMVT(pool);
AVERT(MVT, mvt);
arena = PoolArena(pool);
AVERT(Arena, arena);
mvt->sig = SigInvalid;
@ -450,7 +447,8 @@ static void MVTFinish(Pool pool)
LandFinish(MVTFreeLand(mvt));
LandFinish(MVTFreeSecondary(mvt));
LandFinish(MVTFreePrimary(mvt));
PoolAbsFinish(pool);
NextMethod(Inst, MVTPool, finish)(inst);
}
@ -1023,36 +1021,37 @@ static Size MVTFreeSize(Pool pool)
/* MVTDescribe -- describe an MVT pool */
static Res MVTDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res MVTDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Pool pool = CouldBeA(AbstractPool, inst);
MVT mvt = CouldBeA(MVTPool, pool);
Res res;
MVT mvt;
if (!TESTT(Pool, pool))
return ResFAIL;
mvt = PoolMVT(pool);
if (!TESTT(MVT, mvt))
return ResFAIL;
if (!TESTC(MVTPool, mvt))
return ResPARAM;
if (stream == NULL)
return ResFAIL;
res = WriteF(stream, depth,
"MVT $P {\n", (WriteFP)mvt,
" minSize: $U\n", (WriteFU)mvt->minSize,
" meanSize: $U\n", (WriteFU)mvt->meanSize,
" maxSize: $U\n", (WriteFU)mvt->maxSize,
" fragLimit: $U\n", (WriteFU)mvt->fragLimit,
" reuseSize: $U\n", (WriteFU)mvt->reuseSize,
" fillSize: $U\n", (WriteFU)mvt->fillSize,
" availLimit: $U\n", (WriteFU)mvt->availLimit,
" abqOverflow: $S\n", WriteFYesNo(mvt->abqOverflow),
" splinter: $S\n", WriteFYesNo(mvt->splinter),
" splinterBase: $A\n", (WriteFA)mvt->splinterBase,
" splinterLimit: $A\n", (WriteFU)mvt->splinterLimit,
" size: $U\n", (WriteFU)mvt->size,
" allocated: $U\n", (WriteFU)mvt->allocated,
" available: $U\n", (WriteFU)mvt->available,
" unavailable: $U\n", (WriteFU)mvt->unavailable,
res = NextMethod(Inst, MVTPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2,
"minSize: $U\n", (WriteFU)mvt->minSize,
"meanSize: $U\n", (WriteFU)mvt->meanSize,
"maxSize: $U\n", (WriteFU)mvt->maxSize,
"fragLimit: $U\n", (WriteFU)mvt->fragLimit,
"reuseSize: $U\n", (WriteFU)mvt->reuseSize,
"fillSize: $U\n", (WriteFU)mvt->fillSize,
"availLimit: $U\n", (WriteFU)mvt->availLimit,
"abqOverflow: $S\n", WriteFYesNo(mvt->abqOverflow),
"splinter: $S\n", WriteFYesNo(mvt->splinter),
"splinterBase: $A\n", (WriteFA)mvt->splinterBase,
"splinterLimit: $A\n", (WriteFU)mvt->splinterLimit,
"size: $U\n", (WriteFU)mvt->size,
"allocated: $U\n", (WriteFU)mvt->allocated,
"available: $U\n", (WriteFU)mvt->available,
"unavailable: $U\n", (WriteFU)mvt->unavailable,
NULL);
if (res != ResOK)
return res;
@ -1103,8 +1102,7 @@ static Res MVTDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
METER_WRITE(mvt->exceptionSplinters, stream, depth + 2);
METER_WRITE(mvt->exceptionReturns, stream, depth + 2);
res = WriteF(stream, depth, "} MVT $P\n", (WriteFP)mvt, NULL);
return res;
return ResOK;
}
@ -1353,23 +1351,9 @@ static Bool MVTCheckFit(Addr base, Addr limit, Size min, Arena arena)
}
/* Return the CBS of an MVT pool for the benefit of fotest.c. */
extern Land _mps_mvt_cbs(Pool);
Land _mps_mvt_cbs(Pool pool) {
MVT mvt;
AVERT(Pool, pool);
mvt = PoolMVT(pool);
AVERT(MVT, mvt);
return MVTFreePrimary(mvt);
}
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

103
mps/code/poolmvff.c
View file

@ -1,7 +1,7 @@
/* poolmvff.c: First Fit Manual Variable Pool
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*
* .purpose: This is a pool class for manually managed objects of
@ -297,7 +297,11 @@ static Res mvffFindFree(Range rangeReturn, MVFF mvff, Size size,
}
/* MVFFAlloc -- Allocate a block */
/* MVFFAlloc -- Allocate a block
*
* .alloc.critical: In manual-allocation-bound programs this is on the
* critical path.
*/
static Res MVFFAlloc(Addr *aReturn, Pool pool, Size size)
{
@ -307,11 +311,11 @@ static Res MVFFAlloc(Addr *aReturn, Pool pool, Size size)
LandFindMethod findMethod;
FindDelete findDelete;
AVER(aReturn != NULL);
AVERT(Pool, pool);
AVER_CRITICAL(aReturn != NULL);
AVERT_CRITICAL(Pool, pool);
mvff = PoolMVFF(pool);
AVERT(MVFF, mvff);
AVER(size > 0);
AVERT_CRITICAL(MVFF, mvff);
AVER_CRITICAL(size > 0);
size = SizeAlignUp(size, PoolAlignment(pool));
findMethod = mvff->firstFit ? LandFindFirst : LandFindLast;
@ -321,13 +325,17 @@ static Res MVFFAlloc(Addr *aReturn, Pool pool, Size size)
if (res != ResOK)
return res;
AVER(RangeSize(&range) == size);
AVER_CRITICAL(RangeSize(&range) == size);
*aReturn = RangeBase(&range);
return ResOK;
}
/* MVFFFree -- free the given block */
/* MVFFFree -- free the given block
*
* .free.critical: In manual-allocation-bound programs this is on the
* critical path.
*/
static void MVFFFree(Pool pool, Addr old, Size size)
{
@ -335,18 +343,18 @@ static void MVFFFree(Pool pool, Addr old, Size size)
RangeStruct range, coalescedRange;
MVFF mvff;
AVERT(Pool, pool);
AVERT_CRITICAL(Pool, pool);
mvff = PoolMVFF(pool);
AVERT(MVFF, mvff);
AVERT_CRITICAL(MVFF, mvff);
AVER(old != (Addr)0);
AVER(AddrIsAligned(old, PoolAlignment(pool)));
AVER(size > 0);
AVER_CRITICAL(old != (Addr)0);
AVER_CRITICAL(AddrIsAligned(old, PoolAlignment(pool)));
AVER_CRITICAL(size > 0);
RangeInitSize(&range, old, SizeAlignUp(size, PoolAlignment(pool)));
res = LandInsert(&coalescedRange, MVFFFreeLand(mvff), &range);
/* Insertion must succeed because it fails over to a Freelist. */
AVER(res == ResOK);
AVER_CRITICAL(res == ResOK);
MVFFReduce(mvff);
}
@ -578,7 +586,7 @@ failFreePrimaryInit:
failTotalLandInit:
PoolFinish(MVFFBlockPool(mvff));
failBlockPoolInit:
PoolAbsFinish(pool);
NextMethod(Inst, MVFFPool, finish)(MustBeA(Inst, pool));
failAbsInit:
AVER(res != ResOK);
return res;
@ -604,13 +612,12 @@ static Bool mvffFinishVisitor(Bool *deleteReturn, Land land, Range range,
return TRUE;
}
static void MVFFFinish(Pool pool)
static void MVFFFinish(Inst inst)
{
MVFF mvff;
Pool pool = MustBeA(AbstractPool, inst);
MVFF mvff = MustBeA(MVFFPool, pool);
Bool b;
AVERT(Pool, pool);
mvff = PoolMVFF(pool);
AVERT(MVFF, mvff);
mvff->sig = SigInvalid;
@ -623,7 +630,7 @@ static void MVFFFinish(Pool pool)
LandFinish(MVFFFreePrimary(mvff));
LandFinish(MVFFTotalLand(mvff));
PoolFinish(MVFFBlockPool(mvff));
PoolAbsFinish(pool);
NextMethod(Inst, MVFFPool, finish)(inst);
}
@ -671,28 +678,27 @@ static Size MVFFFreeSize(Pool pool)
/* MVFFDescribe -- describe an MVFF pool */
static Res MVFFDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res MVFFDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Pool pool = CouldBeA(AbstractPool, inst);
MVFF mvff = CouldBeA(MVFFPool, pool);
Res res;
MVFF mvff;
if (!TESTT(Pool, pool))
return ResFAIL;
mvff = PoolMVFF(pool);
if (!TESTT(MVFF, mvff))
return ResFAIL;
if (!TESTC(MVFFPool, mvff))
return ResPARAM;
if (stream == NULL)
return ResFAIL;
return ResPARAM;
res = WriteF(stream, depth,
"MVFF $P {\n", (WriteFP)mvff,
" pool $P ($U)\n",
(WriteFP)pool, (WriteFU)pool->serial,
" extendBy $W\n", (WriteFW)mvff->extendBy,
" avgSize $W\n", (WriteFW)mvff->avgSize,
" firstFit $U\n", (WriteFU)mvff->firstFit,
" slotHigh $U\n", (WriteFU)mvff->slotHigh,
" spare $D\n", (WriteFD)mvff->spare,
res = NextMethod(Inst, MVFFPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth + 2,
"extendBy $W\n", (WriteFW)mvff->extendBy,
"avgSize $W\n", (WriteFW)mvff->avgSize,
"firstFit $U\n", (WriteFU)mvff->firstFit,
"slotHigh $U\n", (WriteFU)mvff->slotHigh,
"spare $D\n", (WriteFD)mvff->spare,
NULL);
if (res != ResOK)
return res;
@ -716,8 +722,7 @@ static Res MVFFDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
if (res != ResOK)
return res;
res = WriteF(stream, depth, "} MVFF $P\n", (WriteFP)mvff, NULL);
return res;
return ResOK;
}
@ -725,17 +730,17 @@ DEFINE_CLASS(Pool, MVFFPool, klass)
{
INHERIT_CLASS(klass, MVFFPool, AbstractPool);
PoolClassMixInBuffer(klass);
klass->instClassStruct.describe = MVFFDescribe;
klass->instClassStruct.finish = MVFFFinish;
klass->size = sizeof(MVFFStruct);
klass->varargs = MVFFVarargs;
klass->init = MVFFInit;
klass->finish = MVFFFinish;
klass->alloc = MVFFAlloc;
klass->free = MVFFFree;
klass->bufferFill = MVFFBufferFill;
klass->bufferEmpty = MVFFBufferEmpty;
klass->totalSize = MVFFTotalSize;
klass->freeSize = MVFFFreeSize;
klass->describe = MVFFDescribe;
}
@ -799,23 +804,9 @@ static Bool MVFFCheck(MVFF mvff)
}
/* Return the CBS of an MVFF pool for the benefit of fotest.c. */
extern Land _mps_mvff_cbs(Pool);
Land _mps_mvff_cbs(Pool pool) {
MVFF mvff;
AVERT(Pool, pool);
mvff = PoolMVFF(pool);
AVERT(MVFF, mvff);
return MVFFFreePrimary(mvff);
}
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

22
mps/code/pooln.c
View file

@ -65,14 +65,15 @@ failAbsInit:
/* NFinish -- finish method for class N */
static void NFinish(Pool pool)
static void NFinish(Inst inst)
{
Pool pool = MustBeA(AbstractPool, inst);
PoolN poolN = MustBeA(NPool, pool);
/* Finish pool-specific structures. */
UNUSED(poolN);
PoolAbsFinish(pool);
NextMethod(Inst, NPool, finish)(inst);
}
@ -139,12 +140,17 @@ static void NBufferEmpty(Pool pool, Buffer buffer,
/* NDescribe -- describe method for class N */
static Res NDescribe(Pool pool, mps_lib_FILE *stream, Count depth)
static Res NDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
PoolN poolN = MustBeA(NPool, pool);
Pool pool = CouldBeA(AbstractPool, inst);
PoolN poolN = CouldBeA(NPool, pool);
Res res;
UNUSED(stream); /* TODO: should output something here */
UNUSED(depth);
res = NextMethod(Inst, NPool, describe)(inst, stream, depth);
if (res != ResOK)
return res;
/* This is where you'd output some information about pool fields. */
UNUSED(poolN);
return ResOK;
@ -251,10 +257,11 @@ static void NTraceEnd(Pool pool, Trace trace)
DEFINE_CLASS(Pool, NPool, klass)
{
INHERIT_CLASS(klass, NPool, AbstractPool);
klass->instClassStruct.describe = NDescribe;
klass->instClassStruct.finish = NFinish;
klass->size = sizeof(PoolNStruct);
klass->attr |= AttrGC;
klass->init = NInit;
klass->finish = NFinish;
klass->alloc = NAlloc;
klass->free = NFree;
klass->bufferFill = NBufferFill;
@ -267,7 +274,6 @@ DEFINE_CLASS(Pool, NPool, klass)
klass->fixEmergency = NFix;
klass->reclaim = NReclaim;
klass->traceEnd = NTraceEnd;
klass->describe = NDescribe;
AVERT(PoolClass, klass);
}

23
mps/code/poolsnc.c
View file

@ -138,8 +138,9 @@ static Res SNCBufInit(Buffer buffer, Pool pool, Bool isMutator, ArgList args)
/* SNCBufFinish -- Finish an SNCBuf */
static void SNCBufFinish(Buffer buffer)
static void SNCBufFinish(Inst inst)
{
Buffer buffer = MustBeA(Buffer, inst);
SNCBuf sncbuf = MustBeA(SNCBuf, buffer);
SNC snc = MustBeA(SNCPool, BufferPool(buffer));
@ -148,7 +149,7 @@ static void SNCBufFinish(Buffer buffer)
sncbuf->sig = SigInvalid;
NextMethod(Buffer, SNCBuf, finish)(buffer);
NextMethod(Inst, SNCBuf, finish)(inst);
}
@ -157,9 +158,9 @@ static void SNCBufFinish(Buffer buffer)
DEFINE_CLASS(Buffer, SNCBuf, klass)
{
INHERIT_CLASS(klass, SNCBuf, RankBuf);
klass->instClassStruct.finish = SNCBufFinish;
klass->size = sizeof(SNCBufStruct);
klass->init = SNCBufInit;
klass->finish = SNCBufFinish;
}
@ -380,13 +381,12 @@ static Res SNCInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
/* SNCFinish -- finish an SNC pool */
static void SNCFinish(Pool pool)
static void SNCFinish(Inst inst)
{
SNC snc;
Pool pool = MustBeA(AbstractPool, inst);
SNC snc = MustBeA(SNCPool, pool);
Ring ring, node, nextNode;
AVERT(Pool, pool);
snc = PoolSNC(pool);
AVERT(SNC, snc);
ring = &pool->segRing;
@ -396,7 +396,7 @@ static void SNCFinish(Pool pool)
SegFree(seg);
}
PoolAbsFinish(pool);
NextMethod(Inst, SNCPool, finish)(inst);
}
@ -560,14 +560,15 @@ static Res SNCFramePop(Pool pool, Buffer buf, AllocFrame frame)
Arena arena;
Seg seg = NULL; /* suppress "may be used uninitialized" */
Bool foundSeg;
Buffer segBuf;
arena = PoolArena(pool);
addr = (Addr)frame;
foundSeg = SegOfAddr(&seg, arena, addr);
AVER(foundSeg);
AVER(foundSeg); /* <design/check/#.common> */
AVER(SegPool(seg) == pool);
if (SegBuffer(seg) == buf) {
if (SegBuffer(&segBuf, seg) && segBuf == buf) {
/* don't need to change the segment - just the alloc pointers */
AVER(addr <= BufferScanLimit(buf)); /* check direction of pop */
BufferSetAllocAddr(buf, addr);
@ -668,10 +669,10 @@ DEFINE_CLASS(Pool, SNCPool, klass)
{
INHERIT_CLASS(klass, SNCPool, AbstractScanPool);
PoolClassMixInFormat(klass);
klass->instClassStruct.finish = SNCFinish;
klass->size = sizeof(SNCStruct);
klass->varargs = SNCVarargs;
klass->init = SNCInit;
klass->finish = SNCFinish;
klass->bufferFill = SNCBufferFill;
klass->bufferEmpty = SNCBufferEmpty;
klass->scan = SNCScan;

17
mps/code/protocol.c
View file

@ -47,6 +47,11 @@ static void InstClassInitInternal(InstClass klass)
klass->level = 0;
klass->display[klass->level] = CLASS_ID(Inst);
/* Generic methods */
klass->describe = InstDescribe;
klass->finish = InstFinish;
klass->init = InstInit;
/* We can't call CLASS(InstClass) here because it causes a loop back
to here, so we have to tie this knot specially. */
klass->instStruct.klass = &CLASS_STATIC(InstClass);
@ -70,6 +75,9 @@ Bool InstClassCheck(InstClass klass)
for (i = klass->level + 1; i < ClassDEPTH; ++i) {
CHECKL(klass->display[i] == NULL);
}
CHECKL(FUNCHECK(klass->describe));
CHECKL(FUNCHECK(klass->finish));
CHECKL(FUNCHECK(klass->init));
return TRUE;
}
@ -101,7 +109,10 @@ static InstClassStruct invalidClassStruct = {
/* .name = */ "Invalid",
/* .superclass = */ &invalidClassStruct,
/* .level = */ 0,
/* .display = */ {(ClassId)&invalidClassStruct}
/* .display = */ {(ClassId)&invalidClassStruct},
/* .describe = */ NULL,
/* .finish = */ NULL,
/* .init = */ NULL,
};
void InstFinish(Inst inst)
@ -143,8 +154,8 @@ Res InstDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
klass = ClassOfPoly(Inst, inst);
return WriteF(stream, depth,
"$S $P\n", (WriteFS)ClassName(klass), inst,
NULL);
"$S $P\n", (WriteFS)ClassName(klass), inst,
NULL);
}

26
mps/code/protocol.h
View file

@ -117,13 +117,13 @@ typedef void *ClassId;
LockClaimGlobalRecursive(); \
if (CLASS_GUARDIAN(className) == FALSE) { \
CLASS_INIT(className)(klass); \
/* Prevent infinite regress. */ \
if (CLASS_ID(className) != CLASS_ID(InstClass) && \
CLASS_ID(className) != CLASS_ID(Inst)) \
/* Prevent infinite regress. */ \
if (CLASS_ID(className) != CLASS_ID(InstClass) && \
CLASS_ID(className) != CLASS_ID(Inst)) \
SetClassOfPoly(klass, CLASS(KIND_CLASS(kind))); \
AVER(CLASS_CHECK(kind)(klass)); \
CLASS_GUARDIAN(className) = TRUE; \
ClassRegister(MustBeA(InstClass, klass)); \
ClassRegister(MustBeA(InstClass, klass)); \
} \
LockReleaseGlobalRecursive(); \
} \
@ -177,6 +177,9 @@ typedef struct InstStruct {
typedef const char *ClassName;
typedef unsigned char ClassLevel;
typedef Res (*DescribeMethod)(Inst inst, mps_lib_FILE *stream, Count depth);
typedef void (*InstInitMethod)(Inst inst);
typedef void (*FinishMethod)(Inst inst);
#define ClassDEPTH 8 /* maximum depth of class hierarchy */
#define InstClassSig ((Sig)0x519B1452) /* SIGnature Protocol INST */
@ -188,6 +191,9 @@ typedef struct InstClassStruct {
InstClass superclass; /* pointer to direct superclass */
ClassLevel level; /* distance from root of class hierarchy */
ClassId display[ClassDEPTH]; /* classes at this level and above */
DescribeMethod describe; /* write a debugging description */
FinishMethod finish; /* finish instance */
InstInitMethod init; /* base init method */
} InstClassStruct;
enum {ClassLevelNoSuper = -1};
@ -248,15 +254,15 @@ extern void ClassRegister(InstClass klass);
#define MustBeA(_class, inst) \
CouldBeA(_class, \
AVERPC(IsNonNullAndA(_class, inst), \
"MustBeA " #_class ": " #inst, \
inst))
AVERPC(IsNonNullAndA(_class, inst), \
"MustBeA " #_class ": " #inst, \
inst))
#define MustBeA_CRITICAL(_class, inst) \
CouldBeA(_class, \
AVERPC_CRITICAL(IsNonNullAndA(_class, inst), \
"MustBeA " #_class ": " #inst, \
inst))
AVERPC_CRITICAL(IsNonNullAndA(_class, inst), \
"MustBeA " #_class ": " #inst, \
inst))
/* Protocol introspection interface

9
mps/code/protxc.c
View file

@ -1,7 +1,7 @@
/* protxc.c: PROTECTION EXCEPTION HANDLER FOR OS X MACH
*
* $Id$
* Copyright (c) 2013-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2013-2016 Ravenbrook Limited. See end of file for license.
*
* This is the protection exception handling code for OS X using the
* Mach interface (not pthreads).
@ -292,7 +292,7 @@ static void *protCatchThread(void *p) {
extern void ProtThreadRegister(Bool setup)
{
kern_return_t kr;
mach_msg_type_number_t old_exception_count;
mach_msg_type_number_t old_exception_count = 1;
exception_mask_t old_exception_masks;
exception_behavior_t behavior;
mach_port_t old_exception_ports;
@ -338,7 +338,8 @@ extern void ProtThreadRegister(Bool setup)
mach_error("ERROR: MPS thread_swap_exception_ports", kr); /* .trans.must */
AVER(old_exception_masks == EXC_MASK_BAD_ACCESS);
AVER(old_exception_count == 1);
AVER(old_exception_ports == MACH_PORT_NULL); /* .assume.only-port */
AVER(old_exception_ports == MACH_PORT_NULL
|| old_exception_ports == protExcPort); /* .assume.only-port */
}
@ -401,7 +402,7 @@ void ProtSetup(void)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* Copyright (C) 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
* All rights reserved. This is an open source license. Contact
* Ravenbrook for commercial licensing options.
*

13
mps/code/pthrdext.c
View file

@ -1,7 +1,7 @@
/* pthreadext.c: POSIX THREAD EXTENSIONS
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .purpose: Provides extension to Pthreads.
*
@ -28,15 +28,6 @@
SRCID(pthreadext, "$Id$");
/* PTHREADEXT_SIGSUSPEND, PTHREADEXT_SIGRESUME -- signals used
*
* See <design/pthreadext/#impl.signals>
*/
#define PTHREADEXT_SIGSUSPEND SIGXFSZ
#define PTHREADEXT_SIGRESUME SIGXCPU
/* Static data initialized on first use of the module
* See <design/pthreadext/#impl.static>.*
*/
@ -366,7 +357,7 @@ unlock:
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

8
mps/code/root.c
View file

@ -129,6 +129,14 @@ Bool RootCheck(Root root)
scan. */
break;
case RootTHREAD:
CHECKD_NOSIG(Thread, root->the.thread.thread); /* <design/check/#hidden-type> */
CHECKL(FUNCHECK(root->the.thread.scan_area));
/* Can't check anything about closure as it could mean anything to
scan_area. */
/* Can't check anything about stackCold. */
break;
case RootTHREAD_TAGGED:
CHECKD_NOSIG(Thread, root->the.thread.thread); /* <design/check/#hidden-type> */
CHECKL(FUNCHECK(root->the.thread.scan_area));

15
mps/code/sacss.c
View file

@ -1,7 +1,7 @@
/* sacss.c: SAC MANUAL ALLOC STRESS TEST
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
* Portions copyright (C) 2002 Global Graphics Software.
*/
@ -74,11 +74,12 @@ static mps_res_t stress(mps_arena_t arena, mps_align_t align,
/* allocate a load of objects */
for (i = 0; i < testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i);
res = make((mps_addr_t *)&ps[i], sac, ss[i]);
res = make(&obj, sac, ss[i]);
if (res != MPS_RES_OK)
return res;
ps[i] = obj;
if (ss[i] >= sizeof(ps[i]))
*ps[i] = 1; /* Write something, so it gets swap. */
}
@ -113,17 +114,19 @@ static mps_res_t stress(mps_arena_t arena, mps_align_t align,
}
/* allocate some new objects */
for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
mps_addr_t obj;
ss[i] = (*size)(i);
switch (k % 2) {
case 0:
res = make((mps_addr_t *)&ps[i], sac, ss[i]);
res = make(&obj, sac, ss[i]);
break;
default:
res = mps_sac_alloc((mps_addr_t *)&ps[i], sac, ss[i], FALSE);
res = mps_sac_alloc(&obj, sac, ss[i], FALSE);
break;
}
if (res != MPS_RES_OK)
return res;
ps[i] = obj;
}
}
@ -246,7 +249,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

215
mps/code/seg.c
View file

@ -127,8 +127,7 @@ static Res SegAbsInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
AVER(SizeIsArenaGrains(size, arena));
AVERT(ArgList, args);
/* Superclass init */
InstInit(CouldBeA(Inst, seg));
NextMethod(Inst, Seg, init)(CouldBeA(Inst, seg));
limit = AddrAdd(base, size);
seg->limit = limit;
@ -187,8 +186,9 @@ static Res SegInit(Seg seg, SegClass klass, Pool pool, Addr base, Size size, Arg
/* SegFinish -- finish a segment */
static void SegAbsFinish(Seg seg)
static void SegAbsFinish(Inst inst)
{
Seg seg = MustBeA(Seg, inst);
Arena arena;
Addr addr, limit;
Tract tract;
@ -241,7 +241,7 @@ static void SegAbsFinish(Seg seg)
static void SegFinish(Seg seg)
{
AVERC(Seg, seg);
Method(Seg, seg, finish)(seg);
Method(Inst, seg, finish)(MustBeA(Inst, seg));
}
@ -327,12 +327,21 @@ void SegSetRankAndSummary(Seg seg, RankSet rankSet, RefSet summary)
}
/* SegBuffer -- return the buffer of a segment */
/* SegHasBuffer -- segment has a buffer? */
Buffer SegBuffer(Seg seg)
Bool SegHasBuffer(Seg seg)
{
Buffer buffer;
return SegBuffer(&buffer, seg);
}
/* SegBuffer -- get the buffer of a segment */
Bool SegBuffer(Buffer *bufferReturn, Seg seg)
{
AVERT_CRITICAL(Seg, seg); /* .seg.critical */
return Method(Seg, seg, buffer)(seg);
return Method(Seg, seg, buffer)(bufferReturn, seg);
}
@ -341,12 +350,20 @@ Buffer SegBuffer(Seg seg)
void SegSetBuffer(Seg seg, Buffer buffer)
{
AVERT(Seg, seg);
if (buffer != NULL)
AVERT(Buffer, buffer);
AVERT(Buffer, buffer);
Method(Seg, seg, setBuffer)(seg, buffer);
}
/* SegUnsetBuffer -- remove the buffer from a segment */
void SegUnsetBuffer(Seg seg)
{
AVERT(Seg, seg);
Method(Seg, seg, unsetBuffer)(seg);
}
/* SegBufferScanLimit -- limit of scannable objects in segment */
Addr SegBufferScanLimit(Seg seg)
@ -356,8 +373,7 @@ Addr SegBufferScanLimit(Seg seg)
AVERT(Seg, seg);
buf = SegBuffer(seg);
if (buf == NULL) {
if (!SegBuffer(&buf, seg)) {
/* Segment is unbuffered: entire segment scannable */
limit = SegLimit(seg);
} else {
@ -370,61 +386,58 @@ Addr SegBufferScanLimit(Seg seg)
/* SegDescribe -- describe a segment */
Res SegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
Res SegAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
Seg seg = CouldBeA(Seg, inst);
Res res;
Pool pool;
SegClass klass;
if (!TESTC(Seg, seg))
return ResPARAM;
if (stream == NULL)
return ResPARAM;
pool = SegPool(seg);
klass = ClassOfPoly(Seg, seg);
res = NextMethod(Inst, Seg, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth,
"Segment $P [$A,$A) {\n", (WriteFP)seg,
(WriteFA)SegBase(seg), (WriteFA)SegLimit(seg),
" class $P (\"$S\")\n",
(WriteFP)klass, (WriteFS)ClassName(klass),
" pool $P ($U)\n",
(WriteFP)pool, (WriteFU)pool->serial,
" depth $U\n", seg->depth,
" pm",
pool = SegPool(seg);
res = WriteF(stream, depth + 2,
"base $A\n", (WriteFA)SegBase(seg),
"limit $A\n", (WriteFA)SegLimit(seg),
"pool $P ($U)\n", (WriteFP)pool, (WriteFU)pool->serial,
"depth $U\n", seg->depth,
"pm",
seg->pm == AccessSetEMPTY ? " EMPTY" : "",
seg->pm & AccessREAD ? " READ" : "",
seg->pm & AccessWRITE ? " WRITE" : "",
"\n",
" sm",
"sm",
seg->sm == AccessSetEMPTY ? " EMPTY" : "",
seg->sm & AccessREAD ? " READ" : "",
seg->sm & AccessWRITE ? " WRITE" : "",
"\n",
" grey $B\n", (WriteFB)seg->grey,
" white $B\n", (WriteFB)seg->white,
" nailed $B\n", (WriteFB)seg->nailed,
" rankSet",
"grey $B\n", (WriteFB)seg->grey,
"white $B\n", (WriteFB)seg->white,
"nailed $B\n", (WriteFB)seg->nailed,
"rankSet",
seg->rankSet == RankSetEMPTY ? " EMPTY" : "",
BS_IS_MEMBER(seg->rankSet, RankAMBIG) ? " AMBIG" : "",
BS_IS_MEMBER(seg->rankSet, RankEXACT) ? " EXACT" : "",
BS_IS_MEMBER(seg->rankSet, RankFINAL) ? " FINAL" : "",
BS_IS_MEMBER(seg->rankSet, RankWEAK) ? " WEAK" : "",
"\n",
NULL);
if (res != ResOK)
return res;
res = Method(Seg, seg, describe)(seg, stream, depth + 2);
if (res != ResOK)
return res;
return ResOK;
}
res = WriteF(stream, 0, "\n", NULL);
if (res != ResOK)
return res;
res = WriteF(stream, depth, "} Segment $P\n", (WriteFP)seg, NULL);
return res;
Res SegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
{
return Method(Inst, seg, describe)(MustBeA(Inst, seg), stream, depth);
}
@ -626,6 +639,7 @@ Res SegSplit(Seg *segLoReturn, Seg *segHiReturn, Seg seg, Addr at)
Arena arena;
Res res;
void *p;
Buffer buffer;
AVER(NULL != segLoReturn);
AVER(NULL != segHiReturn);
@ -641,7 +655,7 @@ Res SegSplit(Seg *segLoReturn, Seg *segHiReturn, Seg seg, Addr at)
/* Can only split a buffered segment if the entire buffer is below
* the split point. */
AVER(SegBuffer(seg) == NULL || BufferLimit(SegBuffer(seg)) <= at);
AVER(!SegBuffer(&buffer, seg) || BufferLimit(buffer) <= at);
if (seg->queued)
ShieldFlush(arena); /* see <design/seg/#split-merge.shield> */
@ -823,11 +837,12 @@ static void segNoSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
/* segNoBuffer -- non-method to return the buffer of a segment */
static Buffer segNoBuffer(Seg seg)
static Bool segNoBuffer(Buffer *bufferReturn, Seg seg)
{
AVERT(Seg, seg);
AVER(bufferReturn != NULL);
NOTREACHED;
return NULL;
return FALSE;
}
@ -836,8 +851,16 @@ static Buffer segNoBuffer(Seg seg)
static void segNoSetBuffer(Seg seg, Buffer buffer)
{
AVERT(Seg, seg);
if (buffer != NULL)
AVERT(Buffer, buffer);
AVERT(Buffer, buffer);
NOTREACHED;
}
/* segNoSetBuffer -- non-method to set the buffer of a segment */
static void segNoUnsetBuffer(Seg seg)
{
AVERT(Seg, seg);
NOTREACHED;
}
@ -1006,39 +1029,6 @@ static Res segTrivSplit(Seg seg, Seg segHi,
}
/* segTrivDescribe -- Basic Seg description method */
static Res segTrivDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
{
Res res;
if (!TESTT(Seg, seg))
return ResFAIL;
if (stream == NULL)
return ResFAIL;
res = WriteF(stream, depth,
"shield depth $U\n", (WriteFU)seg->depth,
"protection mode: ",
(SegPM(seg) & AccessREAD) ? "" : "!", "READ", " ",
(SegPM(seg) & AccessWRITE) ? "" : "!", "WRITE", "\n",
"shield mode: ",
(SegSM(seg) & AccessREAD) ? "" : "!", "READ", " ",
(SegSM(seg) & AccessWRITE) ? "" : "!", "WRITE", "\n",
"ranks:",
RankSetIsMember(seg->rankSet, RankAMBIG) ? " ambiguous" : "",
RankSetIsMember(seg->rankSet, RankEXACT) ? " exact" : "",
RankSetIsMember(seg->rankSet, RankFINAL) ? " final" : "",
RankSetIsMember(seg->rankSet, RankWEAK) ? " weak" : "",
"\n",
"white $B\n", (WriteFB)seg->white,
"grey $B\n", (WriteFB)seg->grey,
"nailed $B\n", (WriteFB)seg->nailed,
NULL);
return res;
}
/* Class GCSeg -- Segment class with GC support
*/
@ -1103,14 +1093,10 @@ static Res gcSegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
/* gcSegFinish -- finish a GC segment */
static void gcSegFinish(Seg seg)
static void gcSegFinish(Inst inst)
{
GCSeg gcseg;
AVERT(Seg, seg);
gcseg = SegGCSeg(seg);
AVERT(GCSeg, gcseg);
AVER(&gcseg->segStruct == seg);
Seg seg = MustBeA(Seg, inst);
GCSeg gcseg = MustBeA(GCSeg, seg);
if (SegGrey(seg) != TraceSetEMPTY) {
RingRemove(&gcseg->greyRing);
@ -1121,13 +1107,13 @@ static void gcSegFinish(Seg seg)
gcseg->sig = SigInvalid;
/* Don't leave a dangling buffer allocating into hyperspace. */
AVER(gcseg->buffer == NULL);
AVER(gcseg->buffer == NULL); /* <design/check/#.common> */
RingFinish(&gcseg->greyRing);
RingFinish(&gcseg->genRing);
/* finish the superclass fields last */
NextMethod(Seg, GCSeg, finish)(seg);
NextMethod(Inst, GCSeg, finish)(inst);
}
@ -1381,7 +1367,7 @@ static void gcSegSetRankSummary(Seg seg, RankSet rankSet, RefSet summary)
/* gcSegBuffer -- GCSeg method to return the buffer of a segment */
static Buffer gcSegBuffer(Seg seg)
static Bool gcSegBuffer(Buffer *bufferReturn, Seg seg)
{
GCSeg gcseg;
@ -1390,7 +1376,12 @@ static Buffer gcSegBuffer(Seg seg)
AVERT_CRITICAL(GCSeg, gcseg); /* .seg.method.check */
AVER_CRITICAL(&gcseg->segStruct == seg);
return gcseg->buffer;
if (gcseg->buffer != NULL) {
*bufferReturn = gcseg->buffer;
return TRUE;
}
return FALSE;
}
@ -1411,6 +1402,15 @@ static void gcSegSetBuffer(Seg seg, Buffer buffer)
}
/* gcSegUnsetBuffer -- GCSeg method to remove the buffer from a segment */
static void gcSegUnsetBuffer(Seg seg)
{
GCSeg gcseg = MustBeA_CRITICAL(GCSeg, seg); /* .seg.method.check */
gcseg->buffer = NULL;
}
/* gcSegMerge -- GCSeg merge method
*
* .buffer: Can't merge two segments both with buffers.
@ -1554,34 +1554,31 @@ failSuper:
/* gcSegDescribe -- GCSeg description method */
static Res gcSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
static Res gcSegDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
{
GCSeg gcseg = CouldBeA(GCSeg, inst);
Res res;
GCSeg gcseg;
if (!TESTT(Seg, seg))
return ResFAIL;
if (!TESTC(GCSeg, gcseg))
return ResPARAM;
if (stream == NULL)
return ResFAIL;
gcseg = SegGCSeg(seg);
if (!TESTT(GCSeg, gcseg))
return ResFAIL;
return ResPARAM;
/* Describe the superclass fields first via next-method call */
res = NextMethod(Seg, GCSeg, describe)(seg, stream, depth);
res = NextMethod(Inst, GCSeg, describe)(inst, stream, depth);
if (res != ResOK)
return res;
res = WriteF(stream, depth,
res = WriteF(stream, depth + 2,
"summary $W\n", (WriteFW)gcseg->summary,
NULL);
if (res != ResOK)
return res;
if (gcseg->buffer == NULL) {
res = WriteF(stream, depth, "buffer: NULL\n", NULL);
res = WriteF(stream, depth + 2, "buffer: NULL\n", NULL);
} else {
res = BufferDescribe(gcseg->buffer, stream, depth);
res = BufferDescribe(gcseg->buffer, stream, depth + 2);
}
if (res != ResOK)
return res;
@ -1594,17 +1591,15 @@ static Res gcSegDescribe(Seg seg, mps_lib_FILE *stream, Count depth)
Bool SegClassCheck(SegClass klass)
{
CHECKD(InstClass, &klass->protocol);
CHECKD(InstClass, &klass->instClassStruct);
CHECKL(klass->size >= sizeof(SegStruct));
CHECKL(FUNCHECK(klass->init));
CHECKL(FUNCHECK(klass->finish));
CHECKL(FUNCHECK(klass->setGrey));
CHECKL(FUNCHECK(klass->setWhite));
CHECKL(FUNCHECK(klass->setRankSet));
CHECKL(FUNCHECK(klass->setRankSummary));
CHECKL(FUNCHECK(klass->merge));
CHECKL(FUNCHECK(klass->split));
CHECKL(FUNCHECK(klass->describe));
CHECKS(SegClass, klass);
return TRUE;
}
@ -1619,20 +1614,21 @@ DEFINE_CLASS(Inst, SegClass, klass)
DEFINE_CLASS(Seg, Seg, klass)
{
INHERIT_CLASS(&klass->protocol, Seg, Inst);
INHERIT_CLASS(&klass->instClassStruct, Seg, Inst);
klass->instClassStruct.describe = SegAbsDescribe;
klass->instClassStruct.finish = SegAbsFinish;
klass->size = sizeof(SegStruct);
klass->init = SegAbsInit;
klass->finish = SegAbsFinish;
klass->setSummary = segNoSetSummary;
klass->buffer = segNoBuffer;
klass->setBuffer = segNoSetBuffer;
klass->setBuffer = segNoSetBuffer;
klass->unsetBuffer = segNoUnsetBuffer;
klass->setGrey = segNoSetGrey;
klass->setWhite = segNoSetWhite;
klass->setRankSet = segNoSetRankSet;
klass->setRankSummary = segNoSetRankSummary;
klass->merge = segTrivMerge;
klass->split = segTrivSplit;
klass->describe = segTrivDescribe;
klass->sig = SegClassSig;
AVERT(SegClass, klass);
}
@ -1645,19 +1641,20 @@ typedef SegClassStruct GCSegClassStruct;
DEFINE_CLASS(Seg, GCSeg, klass)
{
INHERIT_CLASS(klass, GCSeg, Seg);
klass->instClassStruct.describe = gcSegDescribe;
klass->instClassStruct.finish = gcSegFinish;
klass->size = sizeof(GCSegStruct);
klass->init = gcSegInit;
klass->finish = gcSegFinish;
klass->setSummary = gcSegSetSummary;
klass->buffer = gcSegBuffer;
klass->setBuffer = gcSegSetBuffer;
klass->setBuffer = gcSegSetBuffer;
klass->unsetBuffer = gcSegUnsetBuffer;
klass->setGrey = gcSegSetGrey;
klass->setWhite = gcSegSetWhite;
klass->setRankSet = gcSegSetRankSet;
klass->setRankSummary = gcSegSetRankSummary;
klass->merge = gcSegMerge;
klass->split = gcSegSplit;
klass->describe = gcSegDescribe;
AVERT(SegClass, klass);
}

34
mps/code/segsmss.c
View file

@ -141,12 +141,11 @@ static Res amstSegInit(Seg seg, Pool pool, Addr base, Size size, ArgList args)
/* amstSegFinish -- Finish method for AMST segments */
static void amstSegFinish(Seg seg)
static void amstSegFinish(Inst inst)
{
AMSTSeg amstseg;
Seg seg = MustBeA(Seg, inst);
AMSTSeg amstseg = MustBeA(AMSTSeg, seg);
AVERT(Seg, seg);
amstseg = Seg2AMSTSeg(seg);
AVERT(AMSTSeg, amstseg);
if (amstseg->next != NULL)
@ -156,7 +155,7 @@ static void amstSegFinish(Seg seg)
amstseg->sig = SigInvalid;
/* finish the superclass fields last */
NextMethod(Seg, AMSTSeg, finish)(seg);
NextMethod(Inst, AMSTSeg, finish)(inst);
}
@ -269,9 +268,9 @@ failSuper:
DEFINE_CLASS(Seg, AMSTSeg, klass)
{
INHERIT_CLASS(klass, AMSTSeg, AMSSeg);
klass->instClassStruct.finish = amstSegFinish;
klass->size = sizeof(AMSTSegStruct);
klass->init = amstSegInit;
klass->finish = amstSegFinish;
klass->split = amstSegSplit;
klass->merge = amstSegMerge;
AVERT(SegClass, klass);
@ -345,14 +344,15 @@ static Res AMSTInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
/* AMSTFinish -- the pool class finish method */
static void AMSTFinish(Pool pool)
static void AMSTFinish(Inst inst)
{
AMST amst;
Pool pool = MustBeA(AbstractPool, inst);
AMST amst = MustBeA(AMSTPool, pool);
AVERT(Pool, pool);
amst = PoolAMST(pool);
AVERT(AMST, amst);
amst->sig = SigInvalid;
printf("\nDestroying pool, having performed:\n");
printf(" %"PRIuLONGEST" splits (S)\n", (ulongest_t)amst->splits);
printf(" %"PRIuLONGEST" merges (M)\n", (ulongest_t)amst->merges);
@ -362,8 +362,7 @@ static void AMSTFinish(Pool pool)
printf(" %"PRIuLONGEST" buffered splits (C)\n", (ulongest_t)amst->bsplits);
printf(" %"PRIuLONGEST" buffered merges (J)\n", (ulongest_t)amst->bmerges);
AMSFinish(pool);
amst->sig = SigInvalid;
NextMethod(Inst, AMSTPool, finish)(inst);
}
@ -536,9 +535,9 @@ static Res AMSTBufferFill(Addr *baseReturn, Addr *limitReturn,
if (SegLimit(seg) == limit && SegBase(seg) == base) {
if (amstseg->prev != NULL) {
Seg segLo = AMSTSeg2Seg(amstseg->prev);
if (SegBuffer(segLo) == NULL &&
SegGrey(segLo) == SegGrey(seg) &&
SegWhite(segLo) == SegWhite(seg)) {
if (!SegHasBuffer(segLo) &&
SegGrey(segLo) == SegGrey(seg) &&
SegWhite(segLo) == SegWhite(seg)) {
/* .merge */
Seg mergedSeg;
Res mres;
@ -599,10 +598,11 @@ static void AMSTStressBufferedSeg(Seg seg, Buffer buffer)
AMST amst;
Arena arena;
Addr limit;
Buffer segBuf;
AVERT(Seg, seg);
AVERT(Buffer, buffer);
AVER(SegBuffer(seg) == buffer);
AVER(SegBuffer(&segBuf, seg) && segBuf == buffer);
amstseg = Seg2AMSTSeg(seg);
AVERT(AMSTSeg, amstseg);
limit = BufferLimit(buffer);
@ -651,9 +651,9 @@ static void AMSTStressBufferedSeg(Seg seg, Buffer buffer)
DEFINE_CLASS(Pool, AMSTPool, klass)
{
INHERIT_CLASS(klass, AMSTPool, AMSPool);
klass->instClassStruct.finish = AMSTFinish;
klass->size = sizeof(AMSTStruct);
klass->init = AMSTInit;
klass->finish = AMSTFinish;
klass->bufferFill = AMSTBufferFill;
}

27
mps/code/shield.c
View file

@ -18,6 +18,8 @@ SRCID(shield, "$Id$");
void ShieldInit(Shield shield)
{
shield->inside = FALSE;
shield->suspended = FALSE;
shield->queuePending = FALSE;
shield->queue = NULL;
shield->length = 0;
shield->next = 0;
@ -25,7 +27,6 @@ void ShieldInit(Shield shield)
shield->depth = 0;
shield->unsynced = 0;
shield->holds = 0;
shield->suspended = FALSE;
shield->sig = ShieldSig;
}
@ -64,11 +65,10 @@ static Bool SegIsSynced(Seg seg);
Bool ShieldCheck(Shield shield)
{
CHECKS(Shield, shield);
CHECKL(BoolCheck(shield->inside));
/* Can't check Boolean bitfields <design/type/#bool.bitfield.check> */
CHECKL(shield->queue == NULL || shield->length > 0);
CHECKL(shield->limit <= shield->length);
CHECKL(shield->next <= shield->limit);
CHECKL(BoolCheck(shield->suspended));
/* The mutator is not suspended while outside the shield
(design.mps.shield.inv.outside.running). */
@ -78,9 +78,6 @@ Bool ShieldCheck(Shield shield)
(design.mps.shield.inv.unsynced.suspended). */
CHECKL(shield->unsynced == 0 || shield->suspended);
/* If any segment is exposed, the mutator is suspended. */
CHECKL(shield->depth == 0 || shield->suspended);
/* The total depth is zero while outside the shield
(design.mps.shield.inv.outside.depth). */
CHECKL(shield->inside || shield->depth == 0);
@ -90,7 +87,7 @@ Bool ShieldCheck(Shield shield)
/* Every unsynced segment should be on the queue, because we have to
remember to sync it before we return to the mutator. */
CHECKL(shield->limit >= shield->unsynced);
CHECKL(shield->limit + shield->queuePending >= shield->unsynced);
/* The mutator is suspeneded if there are any holds. */
CHECKL(shield->holds == 0 || shield->suspended);
@ -100,18 +97,15 @@ Bool ShieldCheck(Shield shield)
16. */
#if defined(AVER_AND_CHECK_ALL)
{
Count depth = 0;
Count unsynced = 0;
Index i;
for (i = 0; i < shield->limit; ++i) {
Seg seg = shield->queue[i];
CHECKD(Seg, seg);
depth += SegDepth(seg);
if (!SegIsSynced(seg))
++unsynced;
}
CHECKL(depth == shield->depth);
CHECKL(unsynced == shield->unsynced);
CHECKL(unsynced + shield->queuePending == shield->unsynced);
}
#endif
@ -409,7 +403,7 @@ static void shieldFlushEntries(Shield shield)
QuickSort((void *)shield->queue, shield->limit,
shieldQueueEntryCompare, UNUSED_POINTER,
&shield->sortStruct);
&shield->sortStruct);
mode = AccessSetEMPTY;
limit = NULL;
@ -539,9 +533,14 @@ static void shieldQueue(Arena arena, Seg seg)
void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
{
Shield shield;
SHIELD_AVERT(Arena, arena);
SHIELD_AVERT(Seg, seg);
AVERT(AccessSet, mode);
shield = ArenaShield(arena);
AVER(!shield->queuePending);
shield->queuePending = TRUE;
/* design.mps.shield.inv.prot.shield preserved */
shieldSetSM(ArenaShield(arena), seg, BS_UNION(SegSM(seg), mode));
@ -549,6 +548,7 @@ void (ShieldRaise)(Arena arena, Seg seg, AccessSet mode)
/* Ensure design.mps.shield.inv.unsynced.suspended and
design.mps.shield.inv.unsynced.depth */
shieldQueue(arena, seg);
shield->queuePending = FALSE;
/* Check queue and segment consistency. */
AVERT(Arena, arena);
@ -619,6 +619,7 @@ static void shieldDebugCheck(Arena arena)
Shield shield;
Seg seg;
Count queued = 0;
Count depth = 0;
AVERT(Arena, arena);
shield = ArenaShield(arena);
@ -626,6 +627,7 @@ static void shieldDebugCheck(Arena arena)
if (SegFirst(&seg, arena))
do {
depth += SegDepth(seg);
if (shield->limit == 0) {
AVER(!seg->queued);
AVER(SegIsSynced(seg));
@ -638,6 +640,7 @@ static void shieldDebugCheck(Arena arena)
}
} while(SegNext(&seg, arena, seg));
AVER(depth == shield->depth);
AVER(queued == shield->limit);
}
#endif

14
mps/code/splay.c
View file

@ -1,7 +1,7 @@
/* splay.c: SPLAY TREE IMPLEMENTATION
*
* $Id$
* Copyright (c) 2001-2015 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .purpose: Splay trees are used to manage potentially unbounded
* collections of ordered things. In the MPS these are usually
@ -509,9 +509,9 @@ static Compare SplaySplitRev(SplayStateStruct *stateReturn,
Tree middle, leftLast, rightFirst;
Compare cmp;
AVERT(SplayTree, splay);
AVER(FUNCHECK(compare));
AVER(!SplayTreeIsEmpty(splay));
AVERT_CRITICAL(SplayTree, splay);
AVER_CRITICAL(FUNCHECK(compare));
AVER_CRITICAL(!SplayTreeIsEmpty(splay));
leftLast = TreeEMPTY;
rightFirst = TreeEMPTY;
@ -633,8 +633,8 @@ static void SplayAssembleRev(SplayTree splay, SplayState state)
{
Tree left, right;
AVERT(SplayTree, splay);
AVER(state->middle != TreeEMPTY);
AVERT_CRITICAL(SplayTree, splay);
AVER_CRITICAL(state->middle != TreeEMPTY);
left = TreeLeft(state->middle);
left = SplayUpdateRightSpine(splay, state->leftLast, left);
@ -1394,7 +1394,7 @@ Res SplayTreeDescribe(SplayTree splay, mps_lib_FILE *stream, Count depth,
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2015 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

12
mps/code/trace.c
View file

@ -813,12 +813,14 @@ void TraceDestroyFinished(Trace trace)
EVENT1(TraceDestroy, trace);
/* Hopefully the trace reclaimed some memory, so clear any emergency.
* Do this before removing the trace from busyTraces, to avoid
* violating <code/global.c#emergency.invariant>. */
ArenaSetEmergency(trace->arena, FALSE);
trace->sig = SigInvalid;
trace->arena->busyTraces = TraceSetDel(trace->arena->busyTraces, trace);
trace->arena->flippedTraces = TraceSetDel(trace->arena->flippedTraces, trace);
/* Hopefully the trace reclaimed some memory, so clear any emergency. */
ArenaSetEmergency(trace->arena, FALSE);
}
@ -1143,7 +1145,7 @@ static Res traceScanSegRes(TraceSet ts, Rank rank, Arena arena, Seg seg)
/* .verify.segsummary: were the seg contents, as found by this
* scan, consistent with the recorded SegSummary?
*/
AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg)));
AVER(RefSetSub(ScanStateUnfixedSummary(ss), SegSummary(seg))); /* <design/check/#.common> */
/* Write barrier deferral -- see design.mps.write-barrier.deferral. */
/* Did the segment refer to the white set? */
@ -1338,7 +1340,7 @@ mps_res_t _mps_fix2(mps_ss_t mps_ss, mps_addr_t *mps_ref_io)
if (!BTGet(chunk->allocTable, i)) {
/* Reference points into a chunk but not to an allocated tract.
* See <design/trace/#exact.legal> */
AVER_CRITICAL(ss->rank < RankEXACT);
AVER_CRITICAL(ss->rank < RankEXACT); /* <design/check/#.common> */
goto done;
}

24
mps/code/tract.c
View file

@ -1,7 +1,7 @@
/* tract.c: PAGE TABLES
*
* $Id$
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* .ullagepages: Pages whose page index is < allocBase are recorded as
* free but never allocated as alloc starts searching after the tables.
@ -60,8 +60,8 @@ Bool TractCheck(Tract tract)
void TractInit(Tract tract, Pool pool, Addr base)
{
AVER(tract != NULL);
AVERT(Pool, pool);
AVER_CRITICAL(tract != NULL);
AVERT_CRITICAL(Pool, pool);
tract->pool.pool = pool;
tract->base = base;
@ -456,11 +456,11 @@ void PageAlloc(Chunk chunk, Index pi, Pool pool)
Addr base;
Page page;
AVERT(Chunk, chunk);
AVER(pi >= chunk->allocBase);
AVER(pi < chunk->pages);
AVER(!BTGet(chunk->allocTable, pi));
AVERT(Pool, pool);
AVERT_CRITICAL(Chunk, chunk);
AVER_CRITICAL(pi >= chunk->allocBase);
AVER_CRITICAL(pi < chunk->pages);
AVER_CRITICAL(!BTGet(chunk->allocTable, pi));
AVERT_CRITICAL(Pool, pool);
page = ChunkPage(chunk, pi);
tract = PageTract(page);
@ -476,9 +476,9 @@ void PageInit(Chunk chunk, Index pi)
{
Page page;
AVERT(Chunk, chunk);
AVER(pi < chunk->pages);
AVERT_CRITICAL(Chunk, chunk);
AVER_CRITICAL(pi < chunk->pages);
page = ChunkPage(chunk, pi);
BTRes(chunk->allocTable, pi);
@ -504,7 +504,7 @@ void PageFree(Chunk chunk, Index pi)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

2
mps/code/walkt0.c
View file

@ -238,7 +238,7 @@ int main(int argc, char *argv[])
test(arena, mps_class_amc());
test(arena, mps_class_amcz());
/* TODO: test(arena, mps_class_ams()); -- see job003738 */
test(arena, mps_class_ams());
test(arena, mps_class_awl());
test(arena, mps_class_lo());
test(arena, mps_class_snc());

15
mps/design/arena.txt
View file

@ -202,12 +202,6 @@ arguments to ``mps_arena_create_k()`` are class-dependent.
.. _design.mps.protocol: protocol
_`.class.init`: However, the generic ``ArenaInit()`` is called from the
class-specific method, rather than vice versa, because the method is
responsible for allocating the memory for the arena descriptor and the
arena lock in the first place. Likewise, ``ArenaFinish()`` is called
from the finish method.
_`.class.fields`: The ``grainSize`` (for allocation and freeing) and
``zoneShift`` (for computing zone sizes and what zone an address is
in) fields in the arena are the responsibility of the each class, and
@ -567,9 +561,10 @@ _`.ld`: The ``historyStruct`` contains fields used to maintain a
history of garbage collection and in particular object motion in order
to implement location dependency.
_`.ld.epoch`: The ``epoch`` is the "current epoch". This is the
number of 'flips' of traces in the arena since the arena was created.
From the mutator's point of view locations change atomically at flip.
_`.ld.epoch`: The ``epoch`` is the "current epoch". This is the number
of "flips" of traces, in which objects might have moved, in the arena
since it was created. From the mutator's point of view, locations
change atomically at flip.
_`.ld.history`: The ``history`` is a circular buffer of
``LDHistoryLENGTH`` elements of type ``RefSet``. These are the
@ -619,7 +614,7 @@ Document History
Copyright and License
---------------------
Copyright © 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
Copyright © 2001-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
All rights reserved. This is an open source license. Contact
Ravenbrook for commercial licensing options.

14
mps/design/buffer.txt
View file

@ -212,13 +212,6 @@ class-specific behaviour. _`.replay.init`: The ``init()`` method
should emit a ``BufferInit<foo>`` event (if there aren't any extra
parameters, ``<foo> = ""``).
``typedef void (*BufferFinishMethod)(Buffer buffer)``
_`.class.method.finish`: ``finish()`` is a class-specific finish
method called from ``BufferFinish()``. Client-defined methods must
call their superclass method (via a next-method call) after performing
any class-specific behaviour.
``typedef void (*BufferAttachMethod)(Buffer buffer, Addr base, Addr limit, Addr init, Size size)``
_`.class.method.attach`: ``attach()`` is a class-specific method
@ -256,13 +249,6 @@ setter method which sets the rank set of a buffer. It is called from
``BufferSetRankSet()``. Clients should not need to define their own
methods for this.
``typedef Res (*BufferDescribeMethod)(Buffer buffer, mps_lib_FILE *stream, Count depth)``
_`.class.method.describe`: ``describe()`` is a class-specific method
called to describe a buffer, via ``BufferDescribe()``. Client-defined
methods must call their superclass method (via a next-method call)
before describing any class-specific state.
Logging
-------

14
mps/design/check.txt
View file

@ -122,6 +122,18 @@ reference this tag. The structure could be considered for addition to
``mpmst.h``.
Common assertions
-----------------
_`.common`: Some assertions are commonly triggered by mistakes in the
:term:`client program`. These are listed in the section "Common
assertions and their causes" in the MPS Reference, together with an
explanation of their likely cause, and advice for fixing the problem.
To assist with keeping the MPS Reference up to date, these assertions
are marked with a cross-reference to this tag. When you update the
assertion, you must also update the MPS Reference.
Document History
----------------
@ -138,7 +150,7 @@ Document History
Copyright and License
---------------------
Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
All rights reserved. This is an open source license. Contact
Ravenbrook for commercial licensing options.

10
mps/design/config.txt
View file

@ -550,6 +550,16 @@ happen if requested explicitly via ``mps_arena_collect()`` or
``mps_arena_step()``, but it also means that protection is not needed,
and so shield operations can be replaced with no-ops in ``mpm.h``.
_`.opt.signal.suspend`: ``CONFIG_PTHREADEXT_SIGSUSPEND`` names the
signal used to suspend a thread, on platforms using the POSIX thread
extensions module. See design.pthreadext.impl.signals_.
.. _design.pthreadext.impl.signals: pthreadext#impl.signals
_`.opt.signal.resume`: ``CONFIG_PTHREADEXT_SIGRESUME`` names the
signal used to resume a thread, on platforms using the POSIX thread
extensions module. See design.pthreadext.impl.signals_.
To document
-----------

4
mps/design/diag.txt
View file

@ -78,7 +78,7 @@ There are two mechanism for getting diagnostic output:
0x00007fff83e42d46 in __kill ()
(gdb) frame 12
#12 0x000000010000b1fc in MVTFree (pool=0x103ffe160, base=0x101dfd000, size=5024) at poolmv2.c:711
711 Res res = CBSInsert(MVTCBS(mvt), base, limit);
711 Res res = CBSInsert(MVTCBS(mvt), base, limit);
(gdb) p MVTDescribe(mvt, mps_lib_get_stdout(), 0)
MVT 0000000103FFE160 {
minSize: 8
@ -238,7 +238,7 @@ Document History
Copyright and License
---------------------
Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
All rights reserved. This is an open source license. Contact
Ravenbrook for commercial licensing options.

28
mps/design/index.txt
View file

@ -213,20 +213,20 @@ References
Document History
----------------
- 2002-05-23 RB_ Created empty catalogue based on P4DTI design document catalogue.
- 2002-06-07 RB_ Added a bunch of design documents referenced by the source code.
- 2002-06-21 NB_ Remove P4DTI reference, which doesn't fit here. Maybe one day we'll have a corporate design document procedure.
- 2002-06-24 RB_ Added fix, object-debug, thread-manager, and thread-safety.
- 2007-02-08 RHSK Added message-gc and shield.
- 2007-06-12 RHSK Added cstyle.
- 2007-06-28 RHSK Added diag.
- 2008-12-04 RHSK Added tests.
- 2008-12-10 RHSK Correct description of message-gc: gc begin or end.
- 2012-09-14 RB_ Added link to critical-path
- 2013-05-10 RB_ Fixed link to sig and added guide.hex.trans
- 2013-05-22 GDR_ Add link to keyword-arguments.
- 2013-05-25 RB_ Replacing "cstyle" with reworked "guide.impl.c.format".
- 2013-06-07 RB_ Converting to reST_. Linking to [RB_2002-06-18]_.
- 2002-05-23 RB_ Created empty catalogue based on P4DTI design document catalogue.
- 2002-06-07 RB_ Added a bunch of design documents referenced by the source code.
- 2002-06-21 NB_ Remove P4DTI reference, which doesn't fit here. Maybe one day we'll have a corporate design document procedure.
- 2002-06-24 RB_ Added fix, object-debug, thread-manager, and thread-safety.
- 2007-02-08 RHSK Added message-gc and shield.
- 2007-06-12 RHSK Added cstyle.
- 2007-06-28 RHSK Added diag.
- 2008-12-04 RHSK Added tests.
- 2008-12-10 RHSK Correct description of message-gc: gc begin or end.
- 2012-09-14 RB_ Added link to critical-path
- 2013-05-10 RB_ Fixed link to sig and added guide.hex.trans
- 2013-05-22 GDR_ Add link to keyword-arguments.
- 2013-05-25 RB_ Replacing "cstyle" with reworked "guide.impl.c.format".
- 2013-06-07 RB_ Converting to reST_. Linking to [RB_2002-06-18]_.
- 2014-01-29 RB_ The arena no longer manages generation zonesets.
- 2014-01-17 GDR_ Add abq, nailboard, range.
- 2016-03-22 RB_ Add write-barier.

12
mps/design/prot.txt
View file

@ -55,11 +55,11 @@ write-protected segment. See ``TraceSegAccess()``.)
Design
------
_`.sol.sync`: If memory protection is not available, only way to meet
`.req.consistent`_, is ensure that no protection is required,
essentially by running the collector until it has no more incremental
work to do. (This makes it impossible to meet real-time requirements
on pause times, but may be the best that can be done.)
_`.sol.sync`: If memory protection is not available, the only way to
meet `.req.consistent`_ is to ensure that no protection is required,
by running the collector until it has no more incremental work to do.
(This makes it impossible to meet real-time requirements on pause
times, but may be the best that can be done.)
_`.sol.fault.handle`: The protection module handles protection faults
by decoding the context of the fault (see
@ -165,7 +165,7 @@ Document History
Copyright and License
---------------------
Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
All rights reserved. This is an open source license. Contact
Ravenbrook for commercial licensing options.

51
mps/design/protocol.txt
View file

@ -90,8 +90,8 @@ describes it, like this::
_`.overview.prefix`: We make use of the fact that we can cast between
structures with common prefixes, or between structures and their first
members, to provide dynamic typing and subtyping (see [K&R_1998]_,
A.8.3).
members, to provide dynamic typing and subtyping (see
[Kernighan_1988]_, A.8.3).
_`.overview.method`: The ``InstClassStruct`` it itself at the start of
a class structure contains pointers to functions that can be called to
@ -129,21 +129,21 @@ class is extended, it becomes a member of a different kind. Kinds
allow subtype checking to be applied to classes as well as instances,
to determine whether methods are available. ::
instance class kind
instance class kind
(e.g. CBS) (e.g. CBSClass) (e.g. LandClassClass)
.----------. .----------. .----------.
.----------. .----------. .----------.
| class |----->| class |----->| class |-->InstClassClass
------------ ------------ ------------
| ... | | sig | | sig |
------------ ------------ ------------
| ... | | name | | name |
------------ ------------ ------------
| ... | |superclass|-. |superclass|-->InstClassClass
------------ ------------ | ------------
| | | ... | | | ... |
|
|
LandClass<-'
------------ ------------ ------------
| ... | | sig | | sig |
------------ ------------ ------------
| ... | | name | | name |
------------ ------------ ------------
| ... | |superclass|-. |superclass|-->InstClassClass
------------ ------------ | ------------
| | | ... | | | ... |
|
|
LandClass<-'
_`.overview.sig.inherit`: Instances (and therefore classes) will
@ -490,7 +490,7 @@ anti-method to clean-up a subsequent failure. ::
static Res AMSSegInit(Seg seg, Pool pool,
Addr base, Size size,
ArgList args)
ArgList args)
{
AMS ams = MustBeA(AMSPool, pool);
Arena arena = PoolArena(pool);
@ -500,7 +500,7 @@ anti-method to clean-up a subsequent failure. ::
/* Initialize the superclass fields first via next-method call */
res = NextMethod(Seg, AMSSeg, init)(seg, pool, base, size, args);
if (res != ResOK)
goto failNextMethod;
goto failNextMethod;
amsseg = CouldBeA(AMSSeg, seg);
amsseg->grains = size >> ams->grainShift;
@ -511,10 +511,10 @@ anti-method to clean-up a subsequent failure. ::
amsseg->ambiguousFixes = FALSE;
res = amsCreateTables(ams, &amsseg->allocTable,
&amsseg->nongreyTable, &amsseg->nonwhiteTable,
arena, amsseg->grains);
&amsseg->nongreyTable, &amsseg->nonwhiteTable,
arena, amsseg->grains);
if (res != ResOK)
goto failCreateTables;
goto failCreateTables;
/* start off using firstFree, see <design/poolams/#no-bit> */
amsseg->allocTableInUse = FALSE;
@ -524,7 +524,7 @@ anti-method to clean-up a subsequent failure. ::
amsseg->ams = ams;
RingInit(&amsseg->segRing);
RingAppend((ams->allocRing)(ams, SegRankSet(seg), size),
&amsseg->segRing);
&amsseg->segRing);
SetClassOfPoly(seg, CLASS(AMSSeg));
amsseg->sig = AMSSegSig;
@ -575,6 +575,8 @@ level. The level is statically defined using enum constants, and the
id is the address of the canonical class object, so the test is fast
and simple.
.. _RB: http://www.ravenbrook.com/consultants/rb/
A. References
-------------
@ -582,14 +584,14 @@ A. References
.. [Cohen_1991] "Type-Extension Type Tests Can Be Performed In
Constant Time"; Norman H Cohen; IBM Thomas J Watson Research
Center; ACM Transactions on Programming Languages and Systems,
Vol. 13 No. 4, pp626-629; 1991-10.
Vol. 13 No. 4, pp. 626-629; 1991-10.
.. [Gibbs_2004] "Fast Dynamic Casting"; Michael Gibbs, Bjarne
Stroustrup; 2004;
<http://www.stroustrup.com/fast_dynamic_casting.pdf>.
.. [K&R_1988] "The C Programming language 2nd Edition";
Brian W. Kernighan, Dennis M. Ritchie; 1998.
.. [Kernighan_1988] "The C Programming language 2nd Edition"; Brian W.
Kernighan, Dennis M. Ritchie; 1988.
B. Document History
@ -612,7 +614,6 @@ B. Document History
- 2016-04-19 RB_ Miscellaneous clean-up in response to review by GDR_.
.. _RB: http://www.ravenbrook.com/consultants/rb/
.. _GDR: http://www.ravenbrook.com/consultants/gdr/

17
mps/design/pthreadext.txt
View file

@ -324,10 +324,17 @@ likely to be generated and/or handled by other parts of the
application and so should not be used (for example, ``SIGSEGV``). Some
implementations of PThreads use some signals for themselves, so they
may not be used; for example, LinuxThreads uses ``SIGUSR1`` and
``SIGUSR2`` for its own purposes. The design abstractly names the
signals ``PTHREADEXT_SIGSUSPEND`` and ``PTHREAD_SIGRESUME``, so that
they may be easily mapped to appropriate real signal values. Candidate
choices are ``SIGXFSZ`` and ``SIGPWR``.
``SIGUSR2`` for its own purposes, and so do popular tools like
Valgrind that we would like to be compatible with the MPS. The design
therefore abstractly names the signals ``PTHREADEXT_SIGSUSPEND`` and
``PTHREAD_SIGRESUME``, so that they may be easily mapped to
appropriate real signal values. Candidate choices are ``SIGXFSZ`` and
``SIGXCPU``.
_`.impl.signals.config`: The identity of the signals used to suspend
and resume threads can be configured at compilation time using the
preprocessor constants ``CONFIG_PTHREADEXT_SIGSUSPEND`` and
``CONFIG_PTHREADEXT_SIGRESUME`` respectively.
Attachments
@ -368,7 +375,7 @@ Document History
Copyright and License
---------------------
Copyright © 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
Copyright © 2013-2016 Ravenbrook Limited <http://www.ravenbrook.com/>.
All rights reserved. This is an open source license. Contact
Ravenbrook for commercial licensing options.

4
mps/design/strategy.txt
View file

@ -542,11 +542,13 @@ clock time when the MPS was entered; ``moreWork`` and ``tracedWork``
are the results of the last call to ``TracePoll()``.
_`.policy.poll.impl`: The implementation keep doing work until either
the maximum pause time is exceeded (see design.mps.arena.pause-time_),
the maximum pause time is exceeded (see `design.mps.arena.pause-time`_),
or there is no more work to do. Then it schedules the next collection
so that there is approximately one call to ``TracePoll()`` for every
``ArenaPollALLOCTIME`` bytes of allocation.
.. _design.mps.arena.pause-time: arena#pause-time
References
----------

8
mps/example/scheme/scheme-advanced.c
View file

@ -1,6 +1,6 @@
/* scheme.c -- SCHEME INTERPRETER EXAMPLE FOR THE MEMORY POOL SYSTEM
*
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* This is a toy interpreter for a subset of the Scheme programming
* language <http://en.wikipedia.org/wiki/Scheme_%28programming_language%29>.
@ -4330,8 +4330,8 @@ static int start(int argc, char *argv[])
topic/root. */
symtab = NULL;
res = mps_root_create_area(&symtab_root, arena, mps_rank_exact(), 0,
&symtab, &symtab + 1,
mps_scan_area, NULL);
&symtab, &symtab + 1,
mps_scan_area, NULL);
if(res != MPS_RES_OK) error("Couldn't register symtab root");
/* The symbol table is strong-key weak-value. */
@ -4619,7 +4619,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

10
mps/example/scheme/scheme.c
View file

@ -1,6 +1,6 @@
/* scheme.c -- SCHEME INTERPRETER EXAMPLE FOR THE MEMORY POOL SYSTEM
*
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2016 Ravenbrook Limited. See end of file for license.
*
* This is a toy interpreter for a subset of the Scheme programming
* language <http://en.wikipedia.org/wiki/Scheme_%28programming_language%29>.
@ -776,8 +776,8 @@ static void rehash(void) {
that both copies are updated atomically to the mutator (this
interpreter). */
res = mps_root_create_area(&symtab_root, arena, mps_rank_exact(), 0,
symtab, symtab + symtab_size,
mps_scan_area, NULL);
symtab, symtab + symtab_size,
mps_scan_area, NULL);
if(res != MPS_RES_OK) error("Couldn't register new symtab root");
for(i = 0; i < old_symtab_size; ++i)
@ -4262,7 +4262,7 @@ static int start(int argc, char *argv[])
assertion failures). See topic/root. */
res = mps_root_create_area(&symtab_root, arena, mps_rank_exact(), 0,
symtab, symtab + symtab_size,
mps_scan_area, NULL);
mps_scan_area, NULL);
if(res != MPS_RES_OK) error("Couldn't register symtab root");
error_handler = &jb;
@ -4507,7 +4507,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* 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.
*

7
mps/manual/build.txt
View file

@ -136,17 +136,16 @@ well:
Platform OS Architecture Compiler Makefile
========== ========= ============= ============ =================
``fri3gc`` FreeBSD IA-32 GCC ``fri3gc.gmk``
``fri6gc`` FreeBSD x86_64 GCC ``fri6gc.gmk``
``fri3ll`` FreeBSD IA-32 Clang ``fri3ll.gmk``
``fri6gc`` FreeBSD x86_64 GCC ``fri6gc.gmk``
``fri6ll`` FreeBSD x86_64 Clang ``fri6ll.gmk``
``lii3gc`` Linux IA-32 GCC ``lii3gc.gmk``
``lii6gc`` Linux x86_64 GCC ``lii6gc.gmk``
``lii6ll`` Linux x86_64 Clang ``lii6ll.gmk``
``xci3ll`` Mac OS X IA-32 Clang ``mps.xcodeproj``
``xci6ll`` Mac OS X x86_64 Clang ``mps.xcodeproj``
``xci3gc`` Mac OS X IA-32 GCC (legacy) ``xci3gc.gmk``
``w3i3mv`` Windows IA-32 Microsoft C ``w3i3mv.nmk``
``w3i6mv`` Windows x86_64 Microsoft C ``w3i6mv.nmk``
``xci3ll`` Mac OS X IA-32 Clang ``mps.xcodeproj``
``xci6ll`` Mac OS X x86_64 Clang ``mps.xcodeproj``
========== ========= ============= ============ =================
Historically, the MPS worked on a much wider variety of platforms, and

34
mps/manual/source/extensions/mps/designs.py
View file

@ -32,7 +32,7 @@ TYPES = '''
mode = re.compile(r'\.\. mode: .*\n')
prefix = re.compile(r'^:Tag: ([a-z][a-z.0-9-]*[a-z0-9])$', re.MULTILINE)
rst_tag = re.compile(r'^:(?:Author|Date|Status|Revision|Copyright|Organization|Format|Index terms):.*?$\n', re.MULTILINE | re.IGNORECASE)
rst_tag = re.compile(r'^:(?:Author|Date|Status|Revision|Copyright|Organization|Format|Index terms|Readership):.*?$\n', re.MULTILINE | re.IGNORECASE)
mps_tag = re.compile(r'_`\.([a-z][A-Za-z.0-9_-]*[A-Za-z0-9])`:')
mps_ref = re.compile(r'`(\.[a-z][A-Za-z.0-9_-]*[A-Za-z0-9])`_(?: )?')
funcdef = re.compile(r'^``([^`]*\([^`]*\))``$', re.MULTILINE)
@ -61,10 +61,10 @@ def secnum_sub(m):
# .. [THVV_1995] Tom Van Vleck. 1995. "`Structure Marking <http://www.multicians.org/thvv/marking.html>`__".
citation = re.compile(
r'''
^\.\.\s+(?P<ref>\[.*?\])\s*
"(?P<title>[^"]*?)"\s*
;\s*(?P<author>[^;]*?)\s*
(?:;\s*(?P<organization>[^;]*?)\s*)?
^\.\.\s+(?P<ref>\[[^\n\]]+\])\s*
"(?P<title>[^"]+?)"\s*
;\s*(?P<author>[^;]+?)\s*
(?:;\s*(?P<organization>[^;]+?)\s*)?
;\s*(?P<date>[0-9-]+)\s*
(?:;\s*<\s*(?P<url>[^>]*?)\s*>\s*)?
\.
@ -72,21 +72,19 @@ citation = re.compile(
re.VERBOSE | re.MULTILINE | re.IGNORECASE | re.DOTALL
)
def citation_sub(m):
groups = m.groupdict()
for key in groups:
if groups[key]:
groups[key] = re.sub(r'\s+', ' ', groups[key])
result = '.. {ref} {author}.'.format(**groups)
if groups.get('organization'):
result += ' {organization}.'.format(**groups)
result += ' {date}.'.format(**groups)
if groups.get('url'):
result += ' "`{title} <{url}>`__".'.format(**groups)
groups = {k: re.sub(r'\s+', ' ', v) for k, v in m.groupdict().items() if v}
fmt = '.. {ref} {author}.'
if 'organization' in groups:
fmt += ' {organization}.'
fmt += ' {date}.'
if 'url' in groups:
fmt += ' "`{title} <{url}>`__".'
else:
result += ' "{title}".'.format(**groups)
return result
fmt += ' "{title}".'
return fmt.format(**groups)
index = re.compile(r'^:Index\s+terms:(.*$\n(?:[ \t]+.*$\n)*)', re.MULTILINE | re.IGNORECASE)
index = re.compile(r'^:Index\s+terms:(.*$\n(?:[ \t]+.*$\n)*)',
re.MULTILINE | re.IGNORECASE)
# <http://sphinx-doc.org/markup/misc.html#directive-index>
index_term = re.compile(r'^\s*(\w+):\s*(.*?)\s*$', re.MULTILINE)

6
mps/manual/source/guide/advanced.rst
View file

@ -141,9 +141,9 @@ releasing the resource (here, the Scheme function
But this raises the possibility that a port will be closed twice: once
via ``close-input-port`` and a second time via finalization. So it's
necessary to make ports robust against be closed multiple times. The
toy Scheme interpreter does so by setting ``stream`` to ``NULL``: this
ensures that the file handle won't be closed more than once.
necessary to make ports robust against being closed multiple times.
The toy Scheme interpreter does so by setting ``stream`` to ``NULL``:
this ensures that the file handle won't be closed more than once.
.. code-block:: c
:emphasize-lines: 6

38
mps/manual/source/release.rst
View file

@ -15,10 +15,26 @@ Interface changes
#. Allocation frames are no longer deprecated. See :ref:`topic-frame`.
#. On Linux and FreeBSD, it is now possible to configure the signals
used to suspend and resume threads. See :ref:`topic-thread-signal`.
Other changes
.............
#. It is now possible to register a thread with the MPS multiple times
on OS X, thus supporting the use case where a program that does not
use the MPS is calling into MPS-using code from multiple threads.
(This was already supported on other platforms.) See job003559_.
.. _job003559: https://www.ravenbrook.com/project/mps/issue/job003559/
#. The function :c:func:`mps_arena_formatted_objects_walk` walks the
formatted objects in all pools. Previously this was not implemented
for :ref:`pool-ams` pools. See job003738_.
.. _job003738: https://www.ravenbrook.com/project/mps/issue/job003738/
#. Objects in :ref:`pool-snc` pools are no longer scanned after their
:term:`allocation frame` is popped, and so do not keep objects in
automatically managed pools alive. See job003883_.
@ -36,6 +52,20 @@ Other changes
.. _job004011: https://www.ravenbrook.com/project/mps/issue/job004011/
#. Roots created by :c:func:`mps_root_create_thread_scanned` no longer
cause an assertion failure. See job004036_.
.. _job004036: https://www.ravenbrook.com/project/mps/issue/job004036/
#. The MPS test suite now compiles and passes with GCC 6.1. See job004037_.
.. _job004037: https://www.ravenbrook.com/project/mps/issue/job004037/
#. The MPS no longer passes an uninitialized variable to
:c:func:`thread_swap_exception_ports` on OS X. See job004040_.
.. _job004040: https://www.ravenbrook.com/project/mps/issue/job004040/
.. _release-notes-1.115:
@ -112,6 +142,14 @@ Interface changes
#. The :ref:`pool-snc` pool class now implements
:c:func:`mps_pool_total_size` and :c:func:`mps_pool_free_size`.
#. The (undocumented) reservoir functions
:c:func:`mps_ap_fill_with_reservoir_permit`,
:c:func:`mps_reservoir_available`, :c:func:`mps_reservoir_limit`,
:c:func:`mps_reservoir_limit_set`, and
:c:func:`mps_reserve_with_reservoir_permit`, together with the
``has_reservoir_permit`` arguments to :c:func:`mps_sac_alloc` and
:c:func:`MPS_SAC_ALLOC_FAST` are now deprecated.
Other changes
.............

14
mps/manual/source/topic/allocation.rst
View file

@ -45,6 +45,20 @@ Manual allocation
unaligned, it will be rounded up to the pool's :term:`alignment`
(unless the pool documentation says otherwise).
.. note::
It is tempting to call :c:func:`mps_alloc` with a cast from
the desired pointer type to ``mps_addr_t *``, like this::
my_object *obj;
res = mps_alloc((mps_addr_t *)&obj, pool, sizeof *obj);
if (res != MPS_RES_OK)
error(...);
but this is :term:`type punning`, and its behaviour is not
defined in ANSI/ISO Standard C. See :ref:`topic-interface-pun`
for more details.
.. c:function:: void mps_free(mps_pool_t pool, mps_addr_t addr, size_t size)

12
mps/manual/source/topic/arena.rst
View file

@ -15,8 +15,10 @@ An arena is an object that encapsulates the state of the Memory Pool
System, and tells it where to get the memory it manages. You typically
start a session with the MPS by creating an arena with
:c:func:`mps_arena_create_k` and end the session by destroying it with
:c:func:`mps_arena_destroy`. The only function you might need to call
before making an arena is :c:func:`mps_telemetry_control`.
:c:func:`mps_arena_destroy`. The only functions you might need to call
before making an arena are :term:`telemetry system` functions like
:c:func:`mps_telemetry_set` and the :term:`plinth` function
:c:func:`mps_lib_assert_fail_install`.
Before destroying an arena, you must first destroy all objects and
data in it, as usual for abstract data types in the MPS. If you can't
@ -470,8 +472,8 @@ Arena properties
When the pause time is short, the MPS needs to take more slices of
time in order to make :term:`garbage collection` progress, and
make more use of :term:`barriers (1)` to support
:term:`incremental collection`. This increases time overheads,
and especially operating system overheads.
:term:`incremental garbage collection`. This increases time
overheads, and especially operating system overheads.
The pause time may be set to zero, in which case the MPS returns
as soon as it can, without regard for overall efficiency. This
@ -485,7 +487,7 @@ Arena properties
The pause time may be set to infinity, in which case the MPS
completes all outstanding :term:`garbage collection` work before
returning from an operation. The consequence is that the MPS will
be able to save on the overheads due to :term:`incremental
be able to save on the overheads due to :term:`incremental garbage
collection`, leading to lower total time spent in collection. This
value is suitable for non-interactive applications where total
time is important.

40
mps/manual/source/topic/cache.rst
View file

@ -285,26 +285,34 @@ Allocation interface
.. note::
There's also a macro :c:func:`MPS_SAC_ALLOC_FAST` that does
the same thing. The macro is faster, but generates more code
and does less checking.
1. There's also a macro :c:func:`MPS_SAC_ALLOC_FAST` that does
the same thing. The macro is faster, but generates more
code and does less checking.
.. note::
2. The :term:`client program` is responsible for synchronizing
the access to the cache, but if the cache decides to access
the pool, the MPS will properly synchronize with any other
:term:`threads` that might be accessing the same pool.
The :term:`client program` is responsible for synchronizing
the access to the cache, but if the cache decides to access
the pool, the MPS will properly synchronize with any other
:term:`threads` that might be accessing the same
pool.
3. Blocks allocated through a segregated allocation cache
should only be freed through a segregated allocation cache
with the same class structure. Calling :c:func:`mps_free`
on them can cause :term:`memory leaks`, because the size of
the block might be larger than you think. Naturally, the
cache must also be attached to the same pool.
.. note::
4. It is tempting to call :c:func:`mps_sac_alloc` with a cast
from the desired pointer type to ``mps_addr_t *``, like
this::
Blocks allocated through a segregated allocation cache should
only be freed through a segregated allocation cache with the
same class structure. Calling :c:func:`mps_free` on them can
cause :term:`memory leaks`, because the size of
the block might be larger than you think. Naturally, the cache
must also be attached to the same pool.
my_object *obj;
res = mps_alloc((mps_addr_t *)&obj, sac, sizeof *obj, 0);
if (res != MPS_RES_OK)
error(...);
but this is :term:`type punning`, and its behaviour is not
defined in ANSI/ISO Standard C. See
:ref:`topic-interface-pun` for more details.
.. c:function:: MPS_SAC_ALLOC_FAST(mps_res_t res_v, mps_addr_t *p_v, mps_sac_t sac, size_t size, mps_bool_t has_reservoir_permit)

61
mps/manual/source/topic/deprecated.rst
View file

@ -25,6 +25,15 @@ supported interface.
Deprecated in version 1.115
...........................
.. c:function:: mps_res_t mps_ap_fill_with_reservoir_permit(mps_addr_t *p_o, mps_ap_t mps_ap, size_t size)
.. deprecated::
Identical to :c:func:`mps_ap_fill`, which should be used
instead. Formerly, this function gave the MPS permission to
draw on the ‘low-memory reservoir’, but this no longer exists.
.. c:type:: typedef mps_pool_class_t mps_class_t
.. deprecated::
@ -118,6 +127,41 @@ Deprecated in version 1.115
is the sum of allocated space and free space.
.. c:function:: mps_res_t mps_reserve_with_reservoir_permit(mps_addr_t *p_o, mps_ap_t mps_ap, size_t size)
.. deprecated::
Identical to :c:func:`mps_reserve`, which should be used
instead. Formerly, this function gave the MPS permission to
draw on the ‘low-memory reservoir’, but this no longer
exists.
.. c:function:: void mps_reservoir_limit_set(mps_arena_t arena, size_t size)
.. deprecated::
Has no effect. Formerly, it updated the recommended size of
the ‘low-memory reservoir’, but this no longer exists.
.. c:function:: size_t mps_reservoir_limit(mps_arena_t arena)
.. deprecated::
Returns zero. Formerly, it returned the recommended size of
the ‘low-memory reservoir’, but this no longer exists.
.. c:function:: size_t mps_reservoir_available(mps_arena_t arena)
.. deprecated::
Returns zero. Formerly, it returned the size of the available
memory in the ‘low-memory reservoir’, but this no longer
exists.
.. c:function:: mps_res_t mps_root_create_reg(mps_root_t *root_o, mps_arena_t arena, mps_rank_t rank, mps_rm_t rm, mps_thr_t thr, mps_reg_scan_t reg_scan, void *p, size_t s)
.. deprecated::
@ -274,16 +318,15 @@ Deprecated in version 1.115
.. c:function:: mps_res_t mps_root_create_table_masked(mps_root_t *root_o, mps_arena_t arena, mps_rank_t rank, mps_rm_t rm, mps_addr_t *base, size_t count, mps_word_t mask)
.. deprecated::
This function is equivalent to::
Use :c:func:`mps_root_create_area_tagged` instead, passing
zero for the ``pattern`` argument. This function is equivalent
to::
mps_root_create_area_tagged(root_o, arena, rank, rm,
base, base + size,
mps_scan_area_tagged,
mask, 0)
Use :c:func:`mps_root_create_area_masked` instead, passing
zero for the ``pattern`` argument.
Register a :term:`root` that consists of a vector of :term:`tagged
references` whose pattern is zero.
@ -323,18 +366,12 @@ Deprecated in version 1.115
:ref:`topic-scanning`.
.. note::
:term:`Client programs` are not expected to
write scanning functions of this type. The built-in MPS
function :c:func:`mps_stack_scan_ambig` must be used.
.. c:function:: mps_reg_scan_t mps_stack_scan_ambig
.. deprecated::
Use :c:func:`mps_root_create_thread` instead, passing
Use :c:func:`mps_root_create_thread_tagged` instead, passing
``sizeof(mps_word_t) - 1`` for the ``mask`` argument, and
``0`` for the ``pattern`` argument.

4
mps/manual/source/topic/error.rst
View file

@ -286,7 +286,7 @@ this documentation.
It is necessary to call :c:func:`mps_fmt_destroy` first.
``global.c: RingIsSingle(&arena->rootRing)``
``global.c: RingIsSingle(&arenaGlobals->rootRing)``
The client program called :c:func:`mps_arena_destroy` without
destroying all the :term:`roots` belonging to the arena.
@ -300,7 +300,7 @@ this documentation.
It is necessary to call :c:func:`mps_thread_dereg` first.
``global.c: RingLength(&arenaGlobals->poolRing) == 5``
``global.c: RingLength(&arenaGlobals->poolRing) == 4``
The client program called :c:func:`mps_arena_destroy` without
destroying all the :term:`pools` belonging to the arena.

2
mps/manual/source/topic/finalization.rst
View file

@ -194,7 +194,7 @@ Cautions
are finalized is to maintain a table of :term:`weak
references (1)` to all such objects. The weak references don't
prevent the objects from being finalized, but you can iterate
over the list at an appropriate point and finalize any
over the table at an appropriate point and finalize any
remaining objects yourself.
#. Not all :term:`pool classes` support finalization. In general, only

11
mps/manual/source/topic/format.rst
View file

@ -243,11 +243,12 @@ Cautions
a. call library code;
b. perform a non-local exit (for example, by calling ``longjmp``);
b. perform a non-local exit (for example, by throwing an exception,
or calling :c:func:`longjmp`);
c. call any functions in the MPS other than the fix functions
(:c:func:`mps_fix`, :c:func:`MPS_FIX1`, :c:func:`MPS_FIX12`, and
:c:func:`MPS_FIX2`).
c. call any functions or macros in the MPS other than the fix
macros :c:func:`MPS_FIX1`, :c:func:`MPS_FIX12`, and
:c:func:`MPS_FIX2`.
It's permissible to call other functions in the client program, but
see :c:func:`MPS_FIX_CALL` for a restriction on passing the
@ -368,7 +369,7 @@ Format methods
object format has a non-zero
:c:macro:`MPS_KEY_FMT_HEADER_SIZE`.
.. note::
.. note::
The MPS will ask for padding objects of any size aligned to
the pool alignment, no matter what size objects the pool

2
mps/manual/source/topic/index.rst
View file

@ -30,4 +30,4 @@ Reference
platform
porting
deprecated
security

4
mps/manual/source/topic/location.rst
View file

@ -77,8 +77,8 @@ the function :c:func:`mps_ld_reset`.
.. note::
This means that it is not possible to statically create a location
dependency that has been reset.
It is not possible to statically create a location dependency that
has been reset.
You can call :c:func:`mps_ld_reset` at any later point to clear all
dependencies from the structure. For example, this is normally done

24
mps/manual/source/topic/platform.rst
View file

@ -142,14 +142,7 @@ Platform interface
IA-32 processor architecture, and the GCC compiler.
.. c:macro:: MPS_PF_FRI6GC
A :term:`C` preprocessor macro that indicates, if defined, that
the :term:`platform` consists of the FreeBSD operating system, the
x86-64 processor architecture, and the GCC compiler.
.. c:macro:: MPS_PF_FRI3GC
.. c:macro:: MPS_PF_FRI3LL
A :term:`C` preprocessor macro that indicates, if defined, that
the :term:`platform` consists of the FreeBSD operating system, the
@ -158,6 +151,13 @@ Platform interface
.. c:macro:: MPS_PF_FRI6GC
A :term:`C` preprocessor macro that indicates, if defined, that
the :term:`platform` consists of the FreeBSD operating system, the
x86-64 processor architecture, and the GCC compiler.
.. c:macro:: MPS_PF_FRI6LL
A :term:`C` preprocessor macro that indicates, if defined, that
the :term:`platform` consists of the FreeBSD operating system, the
x86-64 processor architecture, and the Clang/LLVM compiler.
@ -220,6 +220,13 @@ Platform interface
IA-32 processor architecture, and the Clang/LLVM compiler.
.. c:macro:: MPS_PF_XCI6GC
A :term:`C` preprocessor macro that indicates, if defined, that
the :term:`platform` consists of the OS X operating system, the
x86-64 processor architecture, and the GCC compiler.
.. c:macro:: MPS_PF_XCI6LL
A :term:`C` preprocessor macro that indicates, if defined, that
@ -373,6 +380,7 @@ Platform Status
``w3ppmv`` *Not supported*
``xci3gc`` *Not supported*
``xci3ll`` Supported
``xci6gc`` *Not supported*
``xci6ll`` Supported
``xcppgc`` *Not supported*
========== =======================

4
mps/manual/source/topic/plinth.rst
View file

@ -468,8 +468,8 @@ Library module
A :term:`plinth` function to supply a default value for the
:term:`telemetry filter` from the environment. See
:c:func:`mps_telemetry_control` for more information on the
significant of the value.
:envvar:`MPS_TELEMETRY_CONTROL` for more information on the
significance of the value.
Returns the default value of the telemetry filter, as derived from
the environment. It is recommended that the environment be

5
mps/manual/source/topic/porting.rst
View file

@ -66,9 +66,8 @@ usable.
There is a generic implementation in ``protan.c``, which can't
provide memory protection, so it forces memory to be scanned until
that there is no further need to protect it. This means it can't
support incremental collection, and has no control over pause
times.
there is no further need to protect it. This means it can't support
incremental collection, and has no control over pause times.
#. The **protection mutator context** module figures out what the
:term:`mutator` was doing when it caused a :term:`protection

64
mps/manual/source/topic/security.rst Normal file
View file

@ -0,0 +1,64 @@
.. index::
single: security issues
.. _topic-security:
Security issues
===============
This chapter describes security issues that may be present when using
the MPS.
.. index::
pair: security issues; predictable address space layout
single: address space; predictable layout
Predictable address space layout
--------------------------------
The MPS acquires :term:`address space` using the operating system's
:term:`virtual memory` interface (specifically, :c:func:`mmap` on Unix
platforms, and :c:func:`VirtualAlloc` on Windows). None of the
supported platforms randomize the allocated regions of address space,
which means that the :term:`addresses` of :term:`blocks` allocated by
the MPS are predictable: a :term:`client program` that makes an
identical series of calls to the MPS gets an identical series of
addresses back.
This means that if a program using the MPS has a buffer overflow, the
overflow is more easily exploitable by an attacker than if the program
had used :c:func:`malloc` (which has some randomization of the
allocated addresses), because it is easier for an attacker to
determine the address of allocated structures.
There is currently no workaround for this issue. If this affects you,
please :ref:`contact us <contact>`.
.. index::
pair: security issues; telemetry
Telemetry
---------
In its :term:`hot` and :term:`cool` varieties, the MPS contains a
:term:`telemetry system` which can be configured to record a stream of
events for later analysis and debugging. When using the default
:term:`plinth`, the behaviour of the telemetry system is under the
control of the environment variable :envvar:`MPS_TELEMETRY_CONTROL`,
and the telemetry stream is written to the file named by the
environment variable :envvar:`MPS_TELEMETRY_FILENAME`.
This means that an attacker who can set arbitrary environment
variables when running a program that uses the MPS can cause that
program to write a telemetry stream to an arbitrary file. This
behaviour might be unexpected, and might enable a data overwriting
attack, or a denial-of-service attack, since telemetry streams are
typically very large.
If this is an issue for your program, then you can modify or replace
the :ref:`topic-plinth-io` in the :term:`plinth` so that it meets your
requirements, or distribute the :term:`rash` variety of the MPS, which
omits the :term:`telemetry system` entirely, and use the other
varieties only for development and testing.

12
mps/manual/source/topic/telemetry.rst
View file

@ -491,9 +491,10 @@ used in queries, for example:
.. note::
If the ``User`` event category is not turned on in the
:term:`telemetry filter` (via :c:func:`mps_telemetry_control`)
then the string is not sent to the telemetry stream. A label
is still returned in this case, but it is useless.
:term:`telemetry filter` (via :c:func:`mps_telemetry_set` or
:envvar:`MPS_TELEMETRY_CONTROL`) then the string is not sent
to the telemetry stream. A label is still returned in this
case, but it is useless.
.. c:function:: void mps_telemetry_label(mps_addr_t addr, mps_label_t label)
@ -512,8 +513,9 @@ used in queries, for example:
.. note::
If the ``User`` event category is not turned on in the
:term:`telemetry filter` (via :c:func:`mps_telemetry_control`)
then calling this function has no effect.
:term:`telemetry filter` (via :c:func:`mps_telemetry_set` or
:envvar:`MPS_TELEMETRY_CONTROL`) then calling this function
has no effect.
.. index::

36
mps/manual/source/topic/thread.rst
View file

@ -44,8 +44,7 @@ access that memory. This means that threads must be registered with
the MPS by calling :c:func:`mps_thread_reg` (and thread roots created;
see :ref:`topic-root-thread`).
For simplicity, we recommend that a thread must be registered with an
:term:`arena` if:
A thread must be registered with an :term:`arena` if:
* its :term:`control stack` and :term:`registers` form a root (this is
enforced by :c:func:`mps_root_create_thread`); or
@ -70,17 +69,30 @@ Signal and exception handling issues
.. warning::
On Unix platforms (except OS X), the MPS suspends and resumes
threads by sending them signals. There's a shortage of available
signals that aren't already dedicated to other purposes (for
example, ValGrind uses ``SIGUSR1`` and ``SIGUSR2``), so the MPS uses
``SIGXCPU`` and ``SIGXFSZ``. This means that programs must not mask
these two signals.
On Linux and FreeBSD, the MPS suspends and resumes threads by
sending them signals. There's a shortage of available signals that
aren't already dedicated to other purposes (for example, ValGrind
uses ``SIGUSR1`` and ``SIGUSR2``), so the MPS uses ``SIGXCPU`` and
``SIGXFSZ``. This means that programs must not mask or handle
either of these signals.
If your program needs to handle these signals, then it must
co-operate with the MPS. At present, there's no documented
mechanism for co-operating: if you are in this situation, please
:ref:`contact us <contact>`.
If your program needs to mask or handle either of these signals,
then you can configure the MPS to use another pair of signals of
your choosing, by defining these preprocessor constants:
.. c:macro:: CONFIG_PTHREADEXT_SIGSUSPEND
If this preprocessor constant is defined, its definition names
the signal used to suspend a thread. For example::
cc -DCONFIG_PTHREADEXT_SIGSUSPEND=SIGUSR1 -c mps.c
.. c:macro:: CONFIG_PTHREADEXT_SIGRESUME
If this preprocessor constant is defined, its definition names
the signal used to resume a thread. For example::
cc -DCONFIG_PTHREADEXT_SIGSUSPEND=SIGUSR2 -c mps.c
.. warning::

38
mps/test/README
View file

@ -43,3 +43,41 @@ From the test directory, build mpslib.a using the Xcode project::
perl test/qa -i ../code -l ../code/xc/Debug/libmps.a run function/232.c
etc. See "Testing on Unix" above.
Testing on Windows
------------------
In a Cygwin shell, from the test directory::
PLATFORM=w3i6mv # substitute your platform
VARIETY=cool # or hot
CODE=../code # code directory of the branch you are testing
pushd $CODE
nmake /f $PLATFORM.nmk VARIETY=$VARIETY $PLATFORM/$VARIETY/mps.obj
popd
export LANG=C # avoid locale warnings from Perl.
alias qa="perl test/qa -i $CODE -l $CODE/$PLATFORM/$VARIETY/mps.obj"
qa clib
qa run function/5.c
qa runset testsets/passing
The runset command can result in this error::
LINK : fatal error LNK1168: cannot open test/obj/nt_AMD64__pc/tmp_test.exe for writing
You may be able to avoid this by running "View Local Services" from
the Windows Control Panel, double-clicking the "Application
Experience" service, and switching "Startup type" to "Automatic". See
the documentation for LNK1168_.
.. _LNK1168: https://msdn.microsoft.com/en-us/library/hhbdtt6d.aspx
At present, the easiest way to debug a test case is to edit
test/test/script/platform and set::
$comwrap = "vsjitdebugger \"";
But see job004020_.
.. _job004020: https://www.ravenbrook.com/project/mps/issue/job004020/

2
mps/test/argerr/153.c
View file

@ -23,7 +23,7 @@ static void test(void) {
cdie(mps_pool_create(&pool, arena, mps_class_mv(),
1024*32, 1024*16, 1024*256), "pool");
cdie(mps_alloc(&q, pool, (size_t) -100 * mmqaArenaSIZE), "alloc");
cdie(mps_alloc(&q, pool, ((size_t)-1) - 100 * mmqaArenaSIZE), "alloc");
mps_pool_destroy(pool);
mps_arena_destroy(arena);

2
mps/test/conerr/13.c
View file

@ -28,7 +28,7 @@ static void test(void)
/* cdie(mps_arena_create(&arena, mps_arena_class_vm(), mmqaArenaSIZE), "create arena");
*/
arena=malloc(64);
arena=malloc(4096);
cdie(
mps_pool_create(&pool, arena, mps_class_mv(),

4
mps/test/conerr/18.c
View file

@ -6,8 +6,8 @@ TEST_HEADER
link = testlib.o
OUTPUT_SPEC
assert = true
assertfile P= poollo.c
assertcond = FormatArena(pool->format) == arena
assertfile P= poolabs.c
assertcond = FormatArena(format) == arena
END_HEADER
*/

2
mps/test/conerr/2.c
View file

@ -17,7 +17,7 @@ static void test(void)
{
mps_arena_t arena;
arena = malloc(64);
arena = malloc(4096);
mps_arena_destroy(arena);
comment("Destroy arena.");
}

8
mps/test/conerr/25.c
View file

@ -30,13 +30,13 @@ static void test(void)
cdie(mps_ap_create(&ap, pool), "create ap");
cdie(mps_reserve(&obj, ap, 152), "reserve");
(void)mps_commit(ap, &obj, 152);
cdie(mps_reserve(&obj, ap, 256), "reserve");
(void)mps_commit(ap, &obj, 256);
mps_free(pool, obj, 152);
mps_free(pool, obj, 256);
comment("Freed.");
mps_free(pool, obj, 152);
mps_free(pool, obj, 256);
comment("Freed again.");
mps_pool_destroy(pool);

2
mps/test/conerr/53.c
View file

@ -7,7 +7,7 @@ TEST_HEADER
OUTPUT_SPEC
assert = true
assertfile P= ld.c
assertcond = ld->_epoch <= arena->epoch
assertcond = ld->_epoch <= ArenaHistory(arena)->epoch
END_HEADER
*/

2
mps/test/conerr/54.c
View file

@ -7,7 +7,7 @@ TEST_HEADER
OUTPUT_SPEC
assert = true
assertfile P= ld.c
assertcond = ld->_epoch <= arena->epoch
assertcond = ld->_epoch <= history->epoch
END_HEADER
*/

Some files were not shown because too many files have changed in this diff Show more