static mps_res_t mv2_alloc(mps_addr_t *ref, mps_ap_t ap, size_t size) {
mps_res_t res;
size = ((size+7)/8)*8;
do {
MPS_RESERVE_BLOCK(res, *ref, ap, size);
if (res != MPS_RES_OK) return res;
} while (!mps_commit(ap, *ref, size));
return MPS_RES_OK;
}
obj_t scheme_make_character(char c)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(character_s));
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_character");
obj = addr;
obj->character.type = TYPE_CHARACTER;
obj->character.c = c;
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
obj_t scheme_make_integer(long integer)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(integer_s));
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_integer");
obj = addr;
obj->integer.type = TYPE_INTEGER;
obj->integer.integer = integer;
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
obj_t scheme_make_special(char *string)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(special_s));
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_special");
obj = addr;
obj->special.type = TYPE_SPECIAL;
obj->special.name = string;
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
static mps_res_t make(mps_addr_t *p, mps_ap_t ap, size_t size, mps_align_t align)
{
mps_res_t res;
size = alignUp(size, align);
do {
MPS_RESERVE_BLOCK(res, *p, ap, size);
if(res != MPS_RES_OK)
return res;
} while(!mps_commit(ap, *p, size));
return MPS_RES_OK;
}
static mps_addr_t make_with_permit(void)
{
size_t length = rnd() % 20, size = (length+2)*sizeof(mps_word_t);
mps_addr_t p;
mps_res_t res;
do {
MPS_RESERVE_WITH_RESERVOIR_PERMIT_BLOCK(res, p, ap, size);
if (res != MPS_RES_OK) die(res, "MPS_RESERVE_WITH_RESERVOIR_PERMIT_BLOCK");
res = dylan_init(p, size, exactRoots, exactRootsCOUNT);
if (res != MPS_RES_OK) die(res, "dylan_init");
} while(!mps_commit(ap, p, size));
return p;
}
obj_t scheme_make_symbol(size_t length, char string[])
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(symbol_s, string) + length+1);
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_symbol");
obj = addr;
obj->symbol.type = TYPE_SYMBOL;
obj->symbol.length = length;
memcpy(obj->symbol.string, string, length+1);
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
obj_t scheme_make_pair(obj_t car, obj_t cdr)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(pair_s));
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_pair");
obj = addr;
obj->pair.type = TYPE_PAIR;
CAR(obj) = car;
CDR(obj) = cdr;
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
/* probably only ever cause a minor collection). */
static void churn(mps_ap_t ap)
{
int i;
mps_addr_t p;
mps_res_t e;
for (i = 0; i < churnFACTOR; ++i) {
do {
MPS_RESERVE_BLOCK(e, p, ap, 4096);
die(e, "MPS_RESERVE_BLOCK");
die(dylan_init(p, 4096, root, 1), "dylan_init");
} while (!mps_commit(ap, p, 4096));
}
p = NULL;
}
obj_t scheme_make_string(size_t length, char string[])
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(string_s, string) + length+1);
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_string");
obj = addr;
obj->string.type = TYPE_STRING;
obj->string.length = length;
if (string) memcpy(obj->string.string, string, length+1);
else memset(obj->string.string, 0, length+1);
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
obj_t scheme_make_vector(size_t length, obj_t fill)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(vector_s, vector) + length * sizeof(obj_t));
do {
size_t i;
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_vector");
obj = addr;
obj->vector.type = TYPE_VECTOR;
obj->vector.length = length;
for(i = 0; i < length; ++i)
obj->vector.vector[i] = fill;
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
static mps_res_t make(mps_addr_t *p, mps_ap_t ap, size_t size)
{
mps_addr_t addr;
mps_res_t res;
do {
obj_t obj;
res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK)
return res;
obj = addr;
obj->size = size;
obj->pad = 0;
} while (!mps_commit(ap, addr, size));
*p = addr;
return MPS_RES_OK;
}
static mps_addr_t make(void)
{
size_t length = rnd() % 20, size = (length+2) * sizeof(mps_word_t);
mps_addr_t p;
mps_res_t res;
do {
MPS_RESERVE_BLOCK(res, p, ap, size);
if (res)
die(res, "MPS_RESERVE_BLOCK");
res = dylan_init(p, size, exactRoots, exactRootsCOUNT);
if (res)
die(res, "dylan_init");
} while(!mps_commit(ap, p, size));
totalSize += size;
return p;
}
obj_t scheme_make_port(obj_t name, FILE *stream)
{
mps_addr_t port_ref;
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(port_s));
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_port");
obj = addr;
obj->port.type = TYPE_PORT;
obj->port.name = name;
obj->port.stream = stream;
} while(!mps_commit(obj_ap, addr, size));
port_ref = obj;
mps_finalize(scheme_arena, &port_ref);
return obj;
}
static mps_addr_t make(size_t rootsCount)
{
size_t length = rnd() % (scale * avLEN);
size_t size = (length+2) * sizeof(mps_word_t);
mps_addr_t p;
mps_res_t res;
do {
MPS_RESERVE_BLOCK(res, p, ap, size);
if (res)
die(res, "MPS_RESERVE_BLOCK");
res = dylan_init(p, size, exactRoots, rootsCount);
if (res)
die(res, "dylan_init");
} while(!mps_commit(ap, p, size));
return p;
}
static void test(void)
{
mps_arena_t arena;
mps_pool_t pool;
mps_thr_t thread;
mps_root_t root;
mps_chain_t chain;
mps_fmt_t format;
mps_ap_t ap;
mps_addr_t p;
cdie(mps_arena_create(&arena, mps_arena_class_vm(), mmqaArenaSIZE), "create arena");
cdie(mps_thread_reg(&thread, arena), "register thread");
cdie(
mps_root_create_reg(&root, arena, mps_rank_ambig(), 0, thread,
mps_stack_scan_ambig, stackpointer, 0),
"create root");
cdie(
mps_fmt_create_A(&format, arena, &fmtA),
"create format");
formatcomments = 0;
cdie(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
cdie(
mps_pool_create(&pool, arena, mps_class_amc(), format, chain),
"create pool");
cdie(
mps_ap_create(&ap, pool, mps_rank_exact()),
"create ap");
do{
cdie(
mps_reserve(&p, ap, (size_t) 64), "reserve");
}
while (!mps_commit(ap, p, (size_t) HIGHBIT_SIZE+64));
}
obj_t scheme_make_table(size_t length, hash_t hashf, cmp_t cmpf)
{
obj_t obj;
mps_addr_t addr;
size_t l, size = ALIGN_OBJ(sizeof(table_s));
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_table");
obj = addr;
obj->table.type = TYPE_TABLE;
obj->table.buckets = NULL;
} while(!mps_commit(obj_ap, addr, size));
obj->table.hash = hashf;
obj->table.cmp = cmpf;
/* round up to next power of 2 */
for(l = 1; l < length; l *= 2);
obj->table.buckets = scheme_make_buckets(l);
mps_ld_reset(&obj->table.ld, scheme_arena);
return obj;
}
static void test(void)
{
mps_space_t space;
mps_pool_t pool;
mps_thr_t thread;
mps_root_t root;
mps_fmt_t format;
mps_ap_t ap;
mps_addr_t p;
cdie(mps_space_create(&space), "create space");
cdie(mps_thread_reg(&thread, space), "register thread");
cdie(
mps_root_create_reg(&root, space, MPS_RANK_AMBIG, 0, thread,
mps_stack_scan_ambig, stackpointer, 0),
"create root");
cdie(
mps_fmt_create_A(&format, space, &fmtA),
"create format");
formatcomments = 0;
cdie(
mps_pool_create(&pool, space, mps_class_amc(), format),
"create pool");
cdie(
mps_ap_create(&ap, pool, MPS_RANK_EXACT),
"create ap");
do{
cdie(
mps_reserve(&p, ap, (size_t) 64), "reserve");
}
while (!mps_commit(NULL, p, (size_t) 64));
}
obj_t scheme_make_operator(char *name,
entry_t entry, obj_t arguments,
obj_t body, obj_t env, obj_t op_env)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(operator_s));
do {
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_operator");
obj = addr;
obj->operator.type = TYPE_OPERATOR;
obj->operator.name = name;
obj->operator.entry = entry;
obj->operator.arguments = arguments;
obj->operator.body = body;
obj->operator.env = env;
obj->operator.op_env = op_env;
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
/* alloc_table -- create a table with n variable slots
*
* .assume.dylan-obj
*/
static mps_word_t *alloc_table(unsigned long n, mps_ap_t ap)
{
size_t objsize;
void *p;
mps_word_t *object;
objsize = (4 + n) * sizeof(mps_word_t);
objsize = (objsize + MPS_PF_ALIGN-1)/MPS_PF_ALIGN*MPS_PF_ALIGN;
do {
unsigned long i;
die(mps_reserve(&p, ap, objsize), "Reserve Table\n");
object = p;
object[0] = (mps_word_t)table_wrapper;
object[1] = 0;
object[2] = n << 2 | 1;
for(i = 0; i < n; ++i) {
object[3+i] = 0;
}
} while(!mps_commit(ap, p, objsize));
return object;
}
obj_t scheme_make_buckets(size_t length)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(buckets_s, bucket) + length * sizeof(obj->buckets.bucket[0]));
do {
size_t i;
mps_res_t res = mps_reserve(&addr, obj_ap, size);
if (res != MPS_RES_OK) error("out of memory in make_buckets");
obj = addr;
obj->buckets.type = TYPE_BUCKETS;
obj->buckets.length = length;
obj->buckets.used = 0;
obj->buckets.deleted = 0;
for(i = 0; i < length; ++i) {
obj->buckets.bucket[i].key = NULL;
obj->buckets.bucket[i].value = NULL;
}
} while(!mps_commit(obj_ap, addr, size));
return obj;
}
static mps_addr_t make(size_t roots_count)
{
size_t length = rnd() % (2*avLEN);
size_t size = (length+2) * sizeof(mps_word_t);
mps_addr_t p, userP;
mps_res_t res;
do {
MPS_RESERVE_BLOCK(res, p, ap, size + headerSIZE);
if (res)
die(res, "MPS_RESERVE_BLOCK");
userP = (mps_addr_t)((char*)p + headerSIZE);
res = dylan_init(userP, size, exactRoots, roots_count);
if (res)
die(res, "dylan_init");
((int*)p)[0] = realHeader;
((int*)p)[1] = 0xED0ED;
} while(!mps_commit(ap, p, size + headerSIZE));
return userP;
}
mycell *allocone(mps_ap_t ap, int size)
{
mps_addr_t p;
mycell *q;
int i;
size_t bytes;
size_t alignment;
bytes = offsetof(struct data, ref) + size*sizeof(struct refitem);
alignment = MPS_PF_ALIGN; /* needed to make it as wide as size_t */
/* twiddle the value of size to make it aligned */
bytes = (bytes+alignment-1) & ~(alignment-1);
do
{
die(mps_reserve(&p, ap, bytes), "Reserve: ");
INCCOUNT(RESERVE_COUNT);
q=p;
q->data.tag = MCdata;
q->data.id = nextid;
q->data.copycount = 0;
q->data.numrefs = size;
q->data.checkedflag = 0;
q->data.size = bytes;
for(i=0; i<size; i+=1)
{
q->data.ref[i].addr = NULL;
q->data.ref[i].id = 0;
}
}
while (!mps_commit(ap, p, bytes));
INCCOUNT(ALLOC_COUNT);
commentif(alloccomments, "allocated id %li at %p.", nextid, q);
nextid += 1;
return q;
}
static void test(void)
{
mps_arena_t arena;
mps_pool_t pool;
mps_fmt_t format;
mps_ap_t ap;
mps_addr_t p;
cdie(mps_arena_create(&arena, mps_arena_class_vm(), mmqaArenaSIZE), "create arena");
cdie(mps_fmt_create_k(&format, arena, mps_args_none), "create format");
MPS_ARGS_BEGIN(args) {
MPS_ARGS_ADD(args, MPS_KEY_FORMAT, format);
cdie(mps_pool_create_k(&pool, arena, mps_class_ams(), args),
"create pool");
} MPS_ARGS_END(args);
MPS_ARGS_BEGIN(args) {
MPS_ARGS_ADD(args, MPS_KEY_RANK, mps_rank_weak());
cdie(mps_ap_create_k(&ap, pool, args), "create ap");
} MPS_ARGS_END(args);
do {
cdie(mps_reserve(&p, ap, 0x100), "Reserve: ");
} while (!mps_commit(ap, p, 0x100));
comment("Committed.");
mps_ap_destroy(ap);
comment("Destroyed ap.");
mps_pool_destroy(pool);
comment("Destroyed pool.");
mps_fmt_destroy(format);
comment("Destroyed format.");
mps_arena_destroy(arena);
comment("Destroyed arena.");
}
static mps_word_t *alloc_table(size_t n, mps_ap_t ap)
{
size_t objsize;
void *p;
mps_word_t *object;
objsize = (3 + n) * sizeof(mps_word_t);
objsize = size_tAlignUp(objsize, MPS_PF_ALIGN);
do {
size_t i;
die(mps_reserve(&p, ap, objsize), "Reserve Table\n");
object = p;
object[0] = (mps_word_t)table_wrapper;
object[1] = 0;
object[2] = n << 2 | 1;
for(i = 0; i < n; ++i) {
object[3+i] = 0;
}
} while(!mps_commit(ap, p, objsize));
return object;
}
static mps_addr_t make(void)
{
size_t length = rnd() % (avLEN * 2);
size_t size = (length+2) * sizeof(mps_word_t);
mps_addr_t p;
mps_res_t res;
alloc_bytes += size;
for(;;) {
mps_bool_t commit_res;
MPS_RESERVE_BLOCK(res, p, ap, size);
if(res)
die(res, "MPS_RESERVE_BLOCK");
res = dylan_init(p, size, exactRoots, exactRootsCOUNT);
if(res)
die(res, "dylan_init");
commit_res = mps_commit(ap, p, size);
if(commit_res)
break;
}
return p;
}
static void test(void)
{
mps_arena_t arena;
mps_pool_t pool;
mps_thr_t thread;
mps_root_t root;
mps_chain_t chain;
mps_fmt_t format;
mps_ap_t ap;
mps_addr_t p;
mps_addr_t q;
cdie(mps_arena_create(&arena, mps_arena_class_vm(), mmqaArenaSIZE), "create arena");
cdie(mps_thread_reg(&thread, arena), "register thread");
cdie(
mps_root_create_reg(&root, arena, mps_rank_ambig(), 0, thread,
mps_stack_scan_ambig, stackpointer, 0),
"create root");
cdie(
mps_fmt_create_A(&format, arena, &fmtA),
"create format");
cdie(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
cdie(
mps_pool_create(&pool, arena, mps_class_amc(), format, chain),
"create pool");
cdie(
mps_ap_create(&ap, pool, mps_rank_exact()),
"create ap");
do
{
cdie(mps_reserve(&p, ap, 0x100), "Reserve: ");
q = (mps_addr_t) ((char *)p + 0x10);
}
while (!mps_commit(ap, q, 0x100));
comment("Committed.");
mps_ap_destroy(ap);
comment("Destroyed ap.");
mps_pool_destroy(pool);
comment("Destroyed pool.");
mps_fmt_destroy(format);
comment("Destroyed format.");
mps_chain_destroy(chain);
comment("Destroyed chain.");
mps_root_destroy(root);
comment("Destroyed root.");
mps_thread_dereg(thread);
comment("Deregistered thread.");
mps_arena_destroy(arena);
comment("Destroyed arena.");
}
static void *test(void *arg, size_t s)
{
unsigned i; /* index */
mps_ap_t ap;
mps_fmt_t fmt;
mps_chain_t chain;
mps_pool_t amc;
mps_res_t e;
mps_root_t mps_root[2];
mps_addr_t nullref = NULL;
int state[rootCOUNT];
mps_arena_t arena;
void *p = NULL;
mps_message_t message;
arena = (mps_arena_t)arg;
(void)s;
die(mps_fmt_create_A(&fmt, arena, dylan_fmt_A()), "fmt_create\n");
die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
die(mps_pool_create(&amc, arena, mps_class_amc(), fmt, chain),
"pool_create amc\n");
die(mps_root_create_table(&mps_root[0], arena, mps_rank_exact(), (mps_rm_t)0,
root, (size_t)rootCOUNT),
"root_create\n");
die(mps_root_create_table(&mps_root[1], arena, mps_rank_exact(), (mps_rm_t)0,
&p, (size_t)1),
"root_create\n");
die(mps_ap_create(&ap, amc, mps_rank_exact()), "ap_create\n");
/* Make registered-for-finalization objects. */
/* <design/poolmrg/#test.promise.ut.alloc> */
for(i = 0; i < rootCOUNT; ++i) {
do {
MPS_RESERVE_BLOCK(e, p, ap, vectorSIZE);
die(e, "MPS_RES_OK");
die(dylan_init(p, vectorSIZE, &nullref, 1), "dylan_init");
} while (!mps_commit(ap, p, vectorSIZE));
/* store index in vector's slot */
((mps_word_t *)p)[vectorSLOT] = dylan_int(i);
die(mps_finalize(arena, &p), "finalize\n");
root[i] = p; state[i] = rootSTATE;
}
p = NULL;
mps_message_type_enable(arena, mps_message_type_finalization());
/* <design/poolmrg/#test.promise.ut.churn> */
while (mps_collections(arena) < collectionCOUNT) {
/* Perhaps cause (minor) collection */
churn(ap);
/* Maybe make some objects ready-to-finalize */
/* <design/poolmrg/#test.promise.ut.drop> */
for (i = 0; i < rootCOUNT; ++i) {
if (root[i] != NULL && state[i] == rootSTATE) {
if (rnd() % finalizationRATE == 0) {
/* for this object, either... */
if (rnd() % 2 == 0) {
/* ...definalize it, or */
die(mps_definalize(arena, &root[i]), "definalize\n");
state[i] = deadSTATE;
} else {
/* ...expect it to be finalized soon */
state[i] = finalizableSTATE;
}
/* Drop the root reference to it; this makes it */
/* non-E-reachable: so either dead, or ready-to-finalize. */
root[i] = NULL;
}
}
}
/* Test any finalized objects, and perhaps resurrect some */
while (mps_message_poll(arena)) {
mps_word_t *obj;
mps_word_t objind;
mps_addr_t objaddr;
/* <design/poolmrg/#test.promise.ut.message> */
cdie(mps_message_get(&message, arena, mps_message_type_finalization()),
"get");
cdie(0 == mps_message_clock(arena, message),
"message clock should be 0 (unset) for finalization messages");
mps_message_finalization_ref(&objaddr, arena, message);
obj = objaddr;
objind = dylan_int_int(obj[vectorSLOT]);
printf("Finalizing: object %lu at %p\n", objind, objaddr);
/* <design/poolmrg/#test.promise.ut.final.check> */
cdie(root[objind] == NULL, "finalized live");
cdie(state[objind] == finalizableSTATE, "finalized dead");
state[objind] = finalizedSTATE;
/* sometimes resurrect */
if (rnd() % 2 == 0)
root[objind] = objaddr;
mps_message_discard(arena, message);
}
}
/* @@@@ <design/poolmrg/#test.promise.ut.nofinal.check> missing */
mps_ap_destroy(ap);
mps_root_destroy(mps_root[1]);
mps_root_destroy(mps_root[0]);
mps_pool_destroy(amc);
mps_chain_destroy(chain);
mps_fmt_destroy(fmt);
return NULL;
}
static void test(void)
{
mps_arena_t arena;
mps_pool_t pool;
mps_thr_t thread;
mps_root_t root;
mps_ap_t apA, apB;
mps_fmt_t format;
mps_chain_t chain;
mycell *ambigref;
size_t bytes;
size_t alignment;
mps_addr_t q;
int i;
formatcomments = 1;
cdie(mps_arena_create(&arena, mps_arena_class_vm(), mmqaArenaSIZE),
"create arena");
cdie(mps_thread_reg(&thread, arena), "register thread");
cdie(mps_root_create_reg(&root, arena, mps_rank_ambig(), 0, thread,
mps_stack_scan_ambig, stackpointer, 0),
"create root");
cdie(mps_fmt_create_A(&format, arena, &fmtA), "create format");
cdie(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
cdie(mmqa_pool_create_chain(&pool, arena, mps_class_amc(), format, chain),
"create pool");
die(mps_ap_create(&apA, pool, mps_rank_exact()), "create apA");
die(mps_ap_create(&apB, pool, mps_rank_exact()), "create apB");
bytes = offsetof(struct data, ref) + sizeof(struct refitem);
alignment = MPS_PF_ALIGN;
bytes = (bytes+alignment-1)&~(alignment-1);
die(mps_reserve(&q, apB, bytes), "reserve: ");
comment("Reserve");
ambigref = q;
ambigref->data.tag = MCdata;
ambigref->data.id = MCerrorid;
ambigref->data.numrefs = 0;
ambigref->data.size = bytes;
comment("Midallocation");
for(i = 0; i < 40; i++) {
allocdumb(apA, 1024*256);
}
comment("Commit");
asserts(mps_commit(apB, q, bytes) == 0, "Commit succeeded!");
comment("Postallocation");
for(i = 0; i < 40; i++) {
allocdumb(apA, 1024*256);
}
comment("Finished");
mps_ap_destroy(apA);
mps_ap_destroy(apB);
mps_pool_destroy(pool);
mps_chain_destroy(chain);
mps_fmt_destroy(format);
mps_root_destroy(root);
mps_thread_dereg(thread);
mps_arena_destroy(arena);
comment("Destroyed arena.");
}
static void *test(void *arg, size_t s)
{
mps_arena_t arena;
mps_fmt_t fmt;
mps_chain_t chain;
mps_pool_t amc;
mps_root_t mps_root[2];
mps_ap_t ap;
mps_res_t e;
int i;
mps_addr_t nullref = NULL;
void *p = NULL;
int N = rootCOUNT - 1;
arena = (mps_arena_t)arg;
(void)s;
die(mps_fmt_create_A(&fmt, arena, dylan_fmt_A()), "fmt_create\n");
die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
die(mps_pool_create(&amc, arena, mps_class_amc(), fmt, chain),
"pool_create amc\n");
die(mps_root_create_table(&mps_root[0], arena, MPS_RANK_EXACT, (mps_rm_t)0,
root, (size_t)rootCOUNT),
"root_create\n");
die(mps_root_create_table(&mps_root[1], arena, MPS_RANK_EXACT, (mps_rm_t)0,
&p, (size_t)1),
"root_create\n");
die(mps_ap_create(&ap, amc, MPS_RANK_EXACT), "ap_create\n");
/* Make registered-for-finalization objects. */
/* <design/poolmrg/#test.promise.ut.alloc> */
for(i = 0; i < rootCOUNT; ++i) {
do {
MPS_RESERVE_BLOCK(e, p, ap, vectorSIZE(2));
die(e, "MPS_RES_OK");
die(dylan_init(p, vectorSIZE(2), &nullref, 1), "dylan_init");
} while (!mps_commit(ap, p, vectorSIZE(2)));
/* set vector's slots */
((mps_word_t *)p)[vectorSLOT(0)] = dylan_int(i);
((mps_word_t *)p)[vectorSLOT(1)] = (mps_word_t)NULL;
die(mps_finalize(arena, &p), "finalize\n");
root[i] = p; state[i] = rootSTATE;
}
p = NULL;
mps_message_type_enable(arena, mps_message_type_finalization());
mps_arena_collect(arena);
report(arena, 0);
/* make 0 and N finalizable */
root[0] = NULL;
state[0] = finalizableSTATE;
root[N] = NULL;
state[N] = finalizableSTATE;
mps_arena_collect(arena);
report(arena, 2);
/* make 1 and N-1 refer to each other and finalizable */
((mps_word_t *)root[1])[vectorSLOT(1)] = (mps_word_t)root[N-1];
((mps_word_t *)root[N-1])[vectorSLOT(1)] = (mps_word_t)root[1];
root[1] = NULL;
state[1] = finalizableSTATE;
root[N-1] = NULL;
state[N-1] = finalizableSTATE;
mps_arena_collect(arena);
report(arena, 2);
mps_arena_collect(arena);
report(arena, 0);
/* @@@@ <design/poolmrg/#test.promise.ut.nofinal.check> missing */
mps_ap_destroy(ap);
mps_root_destroy(mps_root[1]);
mps_root_destroy(mps_root[0]);
mps_pool_destroy(amc);
mps_chain_destroy(chain);
mps_fmt_destroy(fmt);
return NULL;
}
