static mps_word_t make_indirect_cons(mps_word_t car, mps_word_t cdr,
mps_ap_t ap)
{
mps_word_t cons, indirect;
die(make_dylan_vector(&indirect, ap, 1), "make_dylan_vector");
DYLAN_VECTOR_SLOT(indirect, 0) = DYLAN_INT(object_count);
die(make_dylan_vector(&cons, ap, 3), "make_dylan_vector");
DYLAN_VECTOR_SLOT(cons, 0) = car;
DYLAN_VECTOR_SLOT(cons, 1) = cdr;
DYLAN_VECTOR_SLOT(cons, 2) = indirect;
++ object_count;
return cons;
}
D c_primitive_stop_timer()
{
getrusage(RUSAGE_SELF, &stop);
stop.ru_utime.tv_usec -= start.ru_utime.tv_usec;
stop.ru_utime.tv_sec -= start.ru_utime.tv_sec;
if (stop.ru_utime.tv_usec < 0) {
stop.ru_utime.tv_usec += 1000000;
stop.ru_utime.tv_sec -= 1;
}
{
SOV* value = make_dylan_vector(2);
D* data = (D*)vector_data(value);
data[0] = I(stop.ru_utime.tv_sec);
data[1] = I(stop.ru_utime.tv_usec);
return((D)value);
}
}
static obj_t mkvector(mps_ap_t ap, size_t n) {
mps_word_t v;
RESMUST(make_dylan_vector(&v, ap, n));
return v;
}
static void *testscriptB(void *arg, size_t s)
{
trampDataStruct trampData;
mps_arena_t arena;
mps_thr_t thr;
const char *script;
mps_fmt_t fmt;
mps_chain_t chain;
mps_pool_t amc;
mps_root_t root_table;
mps_ap_t ap;
mps_root_t root_stackreg;
size_t i;
int N = myrootCOUNT - 1;
void *stack_starts_here; /* stack scanning starts here */
Insist(s == sizeof(trampDataStruct));
trampData = *(trampDataStruct*)arg;
arena = trampData.arena;
thr = trampData.thr;
script = trampData.script;
die(mps_fmt_create_A(&fmt, arena, dylan_fmt_A()), "fmt_create");
die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
die(mps_pool_create(&amc, arena, mps_class_amc(), fmt, chain),
"pool_create amc");
for(i = 0; i < myrootCOUNT; ++i) {
myroot[i] = NULL;
}
die(mps_root_create_table(&root_table, arena, mps_rank_exact(), (mps_rm_t)0,
myroot, (size_t)myrootCOUNT),
"root_create");
die(mps_ap_create(&ap, amc, mps_rank_exact()), "ap_create");
/* root_stackreg: stack & registers are ambiguous roots = mutator's workspace */
die(mps_root_create_reg(&root_stackreg, arena,
mps_rank_ambig(), (mps_rm_t)0, thr,
mps_stack_scan_ambig, &stack_starts_here, 0),
"root_stackreg");
/* Make myrootCOUNT registered-for-finalization objects. */
/* Each is a dylan vector with 2 slots, inited to: (index, NULL) */
for(i = 0; i < myrootCOUNT; ++i) {
mps_word_t v;
mps_addr_t v_ref;
die(make_dylan_vector(&v, ap, 2), "make_dylan_vector");
DYLAN_VECTOR_SLOT(v, 0) = DYLAN_INT(i);
DYLAN_VECTOR_SLOT(v, 1) = (mps_word_t)NULL;
v_ref = (mps_addr_t)v;
die(mps_finalize(arena, &v_ref), "finalize");
myroot[i] = (void*)v;
state[i] = rootSTATE;
}
/* .keep-alive: Create some additional inter-object references.
*
* 1 and N-1 don't die until myroot refs to both have been nulled.
*
* 2 and 3 don't die until myroot refs to both have been nulled.
*
* We do this to check that reachability via non-root refs prevents
* finalization.
*/
/* Leave 0 and N containing NULL refs */
/* Make 1 and N-1 refer to each other */
DYLAN_VECTOR_SLOT(myroot[1] , 1) = (mps_word_t)myroot[N-1];
DYLAN_VECTOR_SLOT(myroot[N-1], 1) = (mps_word_t)myroot[1];
/* Make 2 and 3 refer to each other */
DYLAN_VECTOR_SLOT(myroot[2], 1) = (mps_word_t)myroot[3];
DYLAN_VECTOR_SLOT(myroot[3], 1) = (mps_word_t)myroot[2];
/* Stop stack scanning, otherwise stack or register dross from */
/* these setup functions can cause unwanted object retention, */
/* which would mean we don't get the finalization messages we */
/* expect. */
mps_root_destroy(root_stackreg);
mps_message_type_enable(arena, mps_message_type_gc_start());
mps_message_type_enable(arena, mps_message_type_gc());
mps_message_type_enable(arena, mps_message_type_finalization());
testscriptC(arena, script);
mps_ap_destroy(ap);
mps_root_destroy(root_table);
mps_pool_destroy(amc);
mps_chain_destroy(chain);
mps_fmt_destroy(fmt);
return NULL;
}
