static void register_numbered_tree(mps_word_t tree, mps_arena_t arena) { /* don't finalize ints */ if ((tree & 1) == 0) { mps_finalize(arena, (mps_addr_t *)&tree); register_numbered_tree(DYLAN_VECTOR_SLOT(tree, 0), arena); register_numbered_tree(DYLAN_VECTOR_SLOT(tree, 1), arena); } }
static void register_indirect_tree(mps_word_t tree, mps_arena_t arena) { /* don't finalize ints */ if ((tree & 1) == 0) { mps_addr_t indirect = (void *)DYLAN_VECTOR_SLOT(tree,2); die(mps_finalize(arena, &indirect), "mps_finalize"); register_indirect_tree(DYLAN_VECTOR_SLOT(tree, 0), arena); register_indirect_tree(DYLAN_VECTOR_SLOT(tree, 1), arena); } }
static mps_word_t make_numbered_cons(mps_word_t car, mps_word_t cdr, mps_ap_t ap) { mps_word_t cons; 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) = DYLAN_INT(object_count); ++ object_count; return cons; }
/* report -- get and check messages * * Get messages, report what was got, check they are the expected * messages, and (for finalization messages) check that these objects * should have been finalized (because we made them unreachable). * * .discard: The client should always call mps_message_discard when * it has finished with the message. But calling with the "discard" * parameter set to false lets us check how the MPS handles naughty * clients. The undiscarded messages must be cleared up by * ArenaDestroy. */ static void report(mps_arena_t arena, const char *pm, Bool discard) { int found = 0; char mFound = '\0'; mps_message_type_t type; while (mps_message_queue_type(&type, arena)) { mps_message_t message; mps_word_t *obj; mps_word_t objind; mps_addr_t objaddr; cdie(mps_message_get(&message, arena, type), "get"); found += 1; switch(type) { case mps_message_type_gc_start(): { printf(" Begin Collection\n"); mFound = 'b'; break; } case mps_message_type_gc(): { printf(" End Collection\n"); mFound = 'e'; break; } case mps_message_type_finalization(): { mps_message_finalization_ref(&objaddr, arena, message); obj = objaddr; objind = DYLAN_INT_INT(DYLAN_VECTOR_SLOT(obj, 0)); printf(" Finalization for object %"PRIuLONGEST" at %p\n", (ulongest_t)objind, objaddr); cdie(myroot[objind] == NULL, "finalized live"); cdie(state[objind] == finalizableSTATE, "not finalizable"); state[objind] = finalizedSTATE; mFound = 'f'; break; } default: { cdie(0, "message type"); break; } } if(discard) { mps_message_discard(arena, message); /* .discard */ } cdie('\0' != *pm, "Found message, but did not expect any"); cdie(mFound == *pm, "Found message type != Expected message type"); pm++; } mFound = '\0'; cdie(mFound == *pm, "No message found, but expected one"); }
static void aset(obj_t v, size_t i, obj_t val) { DYLAN_VECTOR_SLOT(v, i) = val; }
static obj_t aref(obj_t v, size_t i) { return DYLAN_VECTOR_SLOT(v, i); }
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; }