static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
{
if (!info->pass) {
if (!info->tail_pos) {
if (SAME_OBJ(scheme_values_func, rator))
/* no need to clear for app of `values' */
return;
if (SCHEME_PRIMP(rator)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
/* Don't need to clear stack before an immediate/folding call */
return;
}
info->max_nontail = info->ip;
} else {
if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) {
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) {
if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
/* No point in clearing out any of the closure before the
tail call. */
int i;
for (i = info->selflen; i--; ) {
if ((info->selfstart + i) != info->tlpos)
scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
}
}
}
}
}
}
}
void scheme_sfs_push(SFS_Info *info, int cnt, int track)
{
info->stackpos -= cnt;
if (info->stackpos < 0)
scheme_signal_error("internal error: pushed too deep");
if (track) {
while (cnt--) {
scheme_sfs_used(info, cnt);
}
}
}
void scheme_sfs_push(SFS_Info *info, int cnt, int track)
{
info->stackpos -= cnt;
SFS_LOG(printf("push %d [%d]: %d\n", cnt, track, info->stackpos));
if (info->stackpos < 0)
scheme_signal_error("internal error: pushed too deep");
if (track) {
while (cnt--) {
scheme_sfs_used(info, cnt);
}
}
}
static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
Scheme_Object *body, *rhs, *clears = scheme_null;
int i, pos;
scheme_sfs_start_sequence(info, 2, 1);
rhs = scheme_sfs_expr(lv->value, info, -1);
if (!info->pass
|| (info->ip < info->max_nontail)) {
for (i = 0; i < lv->count; i++) {
pos = lv->position + i;
if (!info->pass)
scheme_sfs_used(info, pos);
else {
int spos;
spos = pos + info->stackpos;
if ((info->max_used[spos] == info->ip)
&& (info->max_calls[spos] > info->ip)) {
/* No one is using the id after we set it.
We still need to set it, in case it's boxed and shared,
but then remove the binding or box. */
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
}
}
body = scheme_sfs_expr(lv->body, info, -1);
body = scheme_sfs_add_clears(body, clears, 1);
lv->value = rhs;
lv->body = body;
return o;
}
Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos)
/* closure_self_pos == -2 => immediately in sequence */
{
Scheme_Type type = SCHEME_TYPE(expr);
int seqn, stackpos, tp;
seqn = info->seqn;
stackpos = info->stackpos;
tp = info->tail_pos;
if (seqn) {
info->seqn = 0;
info->tail_pos = 0;
}
info->ip++;
switch (type) {
case scheme_local_type:
case scheme_local_unbox_type:
if (!info->pass)
scheme_sfs_used(info, SCHEME_LOCAL_POS(expr));
else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) {
int pos, at_ip;
pos = SCHEME_LOCAL_POS(expr);
at_ip = info->max_used[info->stackpos + pos];
if (at_ip < info->max_calls[info->stackpos + pos]) {
if (at_ip == info->ip) {
/* Clear on read: */
expr = scheme_make_local(type, pos, SCHEME_LOCAL_CLEAR_ON_READ);
} else {
/* Someone else clears it: */
expr = scheme_make_local(type, pos, SCHEME_LOCAL_OTHER_CLEARS);
}
} else {
# if MAX_SFS_CLEARING
scheme_signal_error("should have been cleared somewhere");
# endif
}
}
break;
case scheme_application_type:
expr = sfs_application(expr, info);
break;
case scheme_application2_type:
expr = sfs_application2(expr, info);
break;
case scheme_application3_type:
expr = sfs_application3(expr, info);
break;
case scheme_sequence_type:
expr = sfs_sequence(expr, info, closure_self_pos != -2);
break;
case scheme_splice_sequence_type:
expr = sfs_sequence(expr, info, 0);
break;
case scheme_branch_type:
expr = sfs_branch(expr, info);
break;
case scheme_with_cont_mark_type:
expr = sfs_wcm(expr, info);
break;
case scheme_unclosed_procedure_type:
expr = sfs_closure(expr, info, closure_self_pos);
break;
case scheme_let_value_type:
expr = sfs_let_value(expr, info);
break;
case scheme_let_void_type:
expr = sfs_let_void(expr, info);
break;
case scheme_letrec_type:
expr = sfs_letrec(expr, info);
break;
case scheme_let_one_type:
expr = sfs_let_one(expr, info);
break;
case scheme_closure_type:
{
Scheme_Closure *c = (Scheme_Closure *)expr;
if (ZERO_SIZED_CLOSUREP(c)) {
Scheme_Object *code;
code = sfs_closure((Scheme_Object *)c->code, info, closure_self_pos);
if (SAME_TYPE(SCHEME_TYPE(code), scheme_begin0_sequence_type)) {
Scheme_Sequence *seq = (Scheme_Sequence *)code;
c->code = (Scheme_Closure_Data *)seq->array[0];
seq->array[0] = expr;
expr = code;
} else {
c->code = (Scheme_Closure_Data *)code;
}
}
}
break;
case scheme_toplevel_type:
{
int c = SCHEME_TOPLEVEL_DEPTH(expr);
if (info->stackpos + c != info->tlpos)
scheme_signal_error("toplevel access not at expected place");
}
break;
case scheme_case_closure_type:
{
/* FIXME: maybe need to handle eagerly created closure */
}
break;
case scheme_define_values_type:
expr = define_values_sfs(expr, info);
break;
case scheme_define_syntaxes_type:
expr = define_syntaxes_sfs(expr, info);
break;
case scheme_begin_for_syntax_type:
expr = begin_for_syntax_sfs(expr, info);
break;
case scheme_set_bang_type:
expr = set_sfs(expr, info);
break;
case scheme_boxenv_type:
expr = bangboxenv_sfs(expr, info);
break;
case scheme_begin0_sequence_type:
expr = begin0_sfs(expr, info);
break;
case scheme_require_form_type:
expr = top_level_require_sfs(expr, info);
break;
case scheme_varref_form_type:
expr = ref_sfs(expr, info);
break;
case scheme_apply_values_type:
expr = apply_values_sfs(expr, info);
break;
case scheme_case_lambda_sequence_type:
expr = case_lambda_sfs(expr, info);
break;
case scheme_module_type:
expr = module_sfs(expr, info);
break;
case scheme_inline_variant_type:
expr = inline_variant_sfs(expr, info);
break;
default:
break;
}
info->ip++;
if (seqn) {
info->seqn = seqn - 1;
memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
info->stackpos = stackpos;
info->tail_pos = tp;
}
return expr;
}
static Scheme_Object *sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_pos)
{
Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
Scheme_Object *code;
int i, size, has_tl = 0;
size = data->closure_size;
if (size) {
if (info->stackpos + data->closure_map[size - 1] == info->tlpos) {
has_tl = 1;
--size;
}
}
if (!info->pass) {
for (i = size; i--; ) {
scheme_sfs_used(info, data->closure_map[i]);
}
} else {
/* Check whether we need to zero out any stack positions
after capturing them in a closure: */
Scheme_Object *clears = scheme_null;
if (info->ip < info->max_nontail) {
int pos, ip;
for (i = size; i--; ) {
pos = data->closure_map[i] + info->stackpos;
if (pos < info->depth) {
ip = info->max_used[pos];
if ((ip == info->ip)
&& (ip < info->max_calls[pos])) {
pos -= info->stackpos;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
}
}
return scheme_sfs_add_clears(expr, clears, 0);
}
if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SFS)) {
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SFS;
info = scheme_new_sfs_info(data->max_let_depth);
scheme_sfs_push(info, data->closure_size + data->num_params, 1);
if (has_tl)
info->tlpos = info->stackpos + data->closure_size - 1;
if (self_pos >= 0) {
for (i = size; i--; ) {
if (data->closure_map[i] == self_pos) {
info->selfpos = info->stackpos + i;
info->selfstart = info->stackpos;
info->selflen = data->closure_size;
break;
}
}
}
code = scheme_sfs(data->code, info, data->max_let_depth);
/* If any arguments go unused, and if there's a non-tail,
non-immediate call in the body, then we flush the
unused arguments at the start of the body. We assume that
the closure values are used (otherwise they wouldn't
be in the closure). */
if (info->max_nontail) {
int i, pos, cnt;
Scheme_Object *clears = scheme_null;
cnt = data->num_params;
for (i = 0; i < cnt; i++) {
pos = data->max_let_depth - (cnt - i);
if (!info->max_used[pos]) {
pos = i + data->closure_size;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
if (SCHEME_PAIRP(clears))
code = scheme_sfs_add_clears(code, clears, 1);
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR;
}
data->code = code;
}
return expr;
}
static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_pos)
{
Scheme_Lambda *data = (Scheme_Lambda *)expr;
Scheme_Object *code;
int i, size, has_tl = 0;
size = data->closure_size;
if (size) {
if (info->stackpos + data->closure_map[size - 1] == info->tlpos) {
has_tl = 1;
--size;
}
}
if (!info->pass) {
for (i = size; i--; ) {
scheme_sfs_used(info, data->closure_map[i]);
}
} else {
/* Check whether we need to zero out any stack positions
after capturing them in a closure: */
Scheme_Object *clears = scheme_null;
if (info->ip < info->max_nontail) {
int pos, ip;
for (i = size; i--; ) {
pos = data->closure_map[i] + info->stackpos;
if (pos < info->depth) {
ip = info->max_used[pos];
if ((ip == info->ip)
&& (ip < info->max_calls[pos])) {
pos -= info->stackpos;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
}
}
return scheme_sfs_add_clears(expr, clears, 0);
}
if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_SFS)) {
SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_SFS;
info = scheme_new_sfs_info(data->max_let_depth);
scheme_sfs_push(info, data->closure_size + data->num_params, 1);
if (has_tl)
info->tlpos = info->stackpos + data->closure_size - 1;
if (self_pos >= 0) {
for (i = size; i--; ) {
if (data->closure_map[i] == self_pos) {
info->selfpos = info->stackpos + i;
info->selfstart = info->stackpos;
info->selflen = data->closure_size;
break;
}
}
}
/* Never clear typed arguments or typed closure elements: */
if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) {
int delta, size, ct, j, pos;
mzshort *map;
delta = data->closure_size;
size = data->closure_size + data->num_params;
map = data->closure_map;
for (j = 0; j < size; j++) {
ct = scheme_boxmap_get(map, j, delta);
if (ct > LAMBDA_TYPE_TYPE_OFFSET) {
if (j < data->num_params)
pos = info->stackpos + delta + j;
else
pos = info->stackpos + (j - data->num_params);
info->max_used[pos] = FAR_VALUE_FOR_MAX_USED;
}
}
}
code = scheme_sfs(data->body, info, data->max_let_depth);
/* If any arguments go unused, and if there's a non-tail,
non-immediate call in the body, then we flush the
unused arguments at the start of the body. We assume that
the closure values are used (otherwise they wouldn't
be in the closure). */
if (info->max_nontail) {
int i, pos, cnt;
Scheme_Object *clears = scheme_null;
cnt = data->num_params;
for (i = 0; i < cnt; i++) {
pos = data->max_let_depth - (cnt - i);
if (!info->max_used[pos]) {
pos = i + data->closure_size;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
if (SCHEME_PAIRP(clears))
code = scheme_sfs_add_clears(code, clears, 1);
if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST)
SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_NEED_REST_CLEAR;
}
data->body = code;
}
return expr;
}
