static Scheme_Object *
ref_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *a_naya;
Scheme_Object *b_naya;
scheme_sfs_start_sequence(info, 1, 0);
a_naya = scheme_sfs_expr(SCHEME_PTR1_VAL(data), info, -1);
b_naya = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1);
SCHEME_PTR1_VAL(data) = a_naya;
SCHEME_PTR2_VAL(data) = b_naya;
return data;
}
static Scheme_Object *bangboxenv_jit(Scheme_Object *data)
{
Scheme_Object *orig, *naya, *new_data;
orig = SCHEME_PTR2_VAL(data);
naya = jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else {
new_data = scheme_alloc_object();
new_data->type = scheme_boxenv_type;
SCHEME_PTR1_VAL(new_data) = SCHEME_PTR1_VAL(data);
SCHEME_PTR2_VAL(new_data) = naya;
return new_data;
}
}
static Scheme_Object *
apply_values_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *f, *e;
f = SCHEME_PTR1_VAL(data);
e = SCHEME_PTR2_VAL(data);
scheme_sfs_start_sequence(info, 2, 0);
f = scheme_sfs_expr(f, info, -1);
e = scheme_sfs_expr(e, info, -1);
SCHEME_PTR1_VAL(data) = f;
SCHEME_PTR2_VAL(data) = e;
return data;
}
static Scheme_Object *apply_values_jit(Scheme_Object *data)
{
Scheme_Object *f, *e;
f = jit_expr(SCHEME_PTR1_VAL(data));
e = jit_expr(SCHEME_PTR2_VAL(data));
if (SAME_OBJ(f, SCHEME_PTR1_VAL(data))
&& SAME_OBJ(e, SCHEME_PTR2_VAL(data)))
return data;
else {
data = scheme_alloc_object();
data->type = scheme_apply_values_type;
SCHEME_PTR1_VAL(data) = f;
SCHEME_PTR2_VAL(data) = e;
return data;
}
}
Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag)
{
Scheme_Object *o;
o = scheme_alloc_object();
o->type = scheme_cpointer_type;
SCHEME_PTR1_VAL(o) = cptr;
SCHEME_PTR2_VAL(o) = (void *)typetag;
return o;
}
inline static int custodian_member_owner_set(NewGC *gc, void *cust, int set)
{
Scheme_Custodian_Reference *box;
Scheme_Custodian *work = (Scheme_Custodian *) gc->owner_table[set]->originator;
while(work) {
if(work == cust) return 1;
box = work->parent;
work = box ? SCHEME_PTR1_VAL(box) : NULL;
}
return 0;
}
Scheme_Object *read_boxenv(Scheme_Object *o)
{
Scheme_Object *data;
if (!SCHEME_PAIRP(o)) return NULL;
data = scheme_alloc_object();
data->type = scheme_boxenv_type;
SCHEME_PTR1_VAL(data) = SCHEME_CAR(o);
SCHEME_PTR2_VAL(data) = SCHEME_CDR(o);
return data;
}
static uintptr_t custodian_single_time_limit(NewGC *gc, int set)
{
OTEntry **owner_table = gc->owner_table;
const int table_size = gc->owner_table_size;
if (!set)
return gc->place_memory_limit;
if (gc->reset_limits) {
int i;
for(i = 1; i < table_size; i++)
if (owner_table[i])
owner_table[i]->limit_set = 0;
gc->reset_limits = 0;
}
if (!owner_table[set]->limit_set) {
/* Check for limits on this custodian or one of its ancestors: */
uintptr_t limit = gc->place_memory_limit;
Scheme_Custodian *orig = (Scheme_Custodian *) owner_table[set]->originator, *c;
AccountHook *work = gc->hooks;
while(work) {
if ((work->type == MZACCT_LIMIT) && (work->c1 == work->c2)) {
c = orig;
while (1) {
if (work->c2 == c) {
if (work->amount < limit)
limit = work->amount;
break;
}
if (!c->parent)
break;
c = (Scheme_Custodian*)SCHEME_PTR1_VAL(c->parent);
if (!c)
break;
}
}
work = work->next;
}
owner_table[set]->single_time_limit = limit;
owner_table[set]->limit_set = 1;
}
return owner_table[set]->single_time_limit;
}
static Scheme_Object *bangboxenv_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *e;
int spos, drop;
spos = SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)) + info->stackpos;
if (info->pass
&& (info->max_used[spos] < info->ip))
/* Not used, so don't bother boxing. In fact, the original value
might be cleared already, so we wan't legally box anymore. */
drop = 1;
else
drop = 0;
e = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1);
if (drop)
return e;
else {
SCHEME_PTR2_VAL(data) = e;
return data;
}
}
static void BTC_do_accounting(NewGC *gc)
{
const int table_size = gc->owner_table_size;
OTEntry **owner_table = gc->owner_table;
if(gc->really_doing_accounting) {
Scheme_Custodian *cur = owner_table[current_owner(gc, NULL)]->originator, *last, *parent;
Scheme_Custodian_Reference *box = cur->global_next;
int i;
GCDEBUG((DEBUGOUTF, "\nBEGINNING MEMORY ACCOUNTING\n"));
gc->doing_memory_accounting = 1;
gc->in_unsafe_allocation_mode = 1;
gc->unsafe_allocation_abort = btc_overmem_abort;
gc->master_page_btc_mark_checked = 0;
/* clear the memory use numbers out */
for(i = 1; i < table_size; i++)
if(owner_table[i]) {
owner_table[i]->memory_use = 0;
#ifdef MZ_USE_PLACES
if (MASTERGC && MASTERGC->major_places_gc)
owner_table[i]->master_memory_use = 0;
#endif
}
/* start with root: */
while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) {
cur = SCHEME_PTR1_VAL(cur->parent);
}
/* walk forward for the order we want (blame parents instead of children) */
last = cur;
while(cur) {
int owner = custodian_to_owner_set(gc, cur);
uintptr_t save_count = gc->phantom_count;
gc->phantom_count = 0;
gc->current_mark_owner = owner;
GCDEBUG((DEBUGOUTF,"MARKING THREADS OF OWNER %i (CUST %p)\n", owner, cur));
gc->kill_propagation_loop = 0;
mark_threads(gc, owner);
mark_cust_boxes(gc, cur);
GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n"));
propagate_accounting_marks(gc);
last = cur;
box = cur->global_next; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
owner_table = gc->owner_table;
owner_table[owner]->memory_use = add_no_overflow(owner_table[owner]->memory_use,
gcBYTES_TO_WORDS(gc->phantom_count));
gc->phantom_count = save_count;
}
release_master_btc_mark(gc);
/* walk backward folding totals int parent */
cur = last;
while (cur) {
int owner = custodian_to_owner_set(gc, cur);
box = cur->parent; parent = box ? SCHEME_PTR1_VAL(box) : NULL;
if (parent) {
int powner = custodian_to_owner_set(gc, parent);
owner_table = gc->owner_table;
owner_table[powner]->memory_use = add_no_overflow(owner_table[powner]->memory_use,
owner_table[owner]->memory_use);
owner_table[powner]->master_memory_use += owner_table[owner]->master_memory_use;
}
box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
}
gc->in_unsafe_allocation_mode = 0;
gc->doing_memory_accounting = 0;
gc->old_btc_mark = gc->new_btc_mark;
gc->new_btc_mark = !gc->new_btc_mark;
}
clear_stack_pages(gc);
}
Scheme_Object *write_boxenv(Scheme_Object *o)
{
return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o));
}
Scheme_Object *write_apply_values(Scheme_Object *o)
{
return scheme_make_pair(scheme_protect_quote(SCHEME_PTR1_VAL(o)),
scheme_protect_quote(SCHEME_PTR2_VAL(o)));
}
