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;
}
static Scheme_Object *
case_lambda_sfs(Scheme_Object *expr, SFS_Info *info)
{
Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
Scheme_Object *le, *clears = scheme_null;
int i;
scheme_sfs_start_sequence(info, seq->count, 0);
for (i = 0; i < seq->count; i++) {
le = seq->array[i];
le = scheme_sfs_expr(le, info, -1);
if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) {
/* Some clearing actions were added to the closure.
Lift them out. */
int j;
Scheme_Sequence *cseq = (Scheme_Sequence *)le;
if (!cseq->count)
scheme_signal_error("internal error: empty sequence");
for (j = 1; j < cseq->count; j++) {
int pos;
pos = SCHEME_LOCAL_POS(cseq->array[j]);
clears = scheme_make_pair(scheme_make_integer(pos), clears);
}
le = cseq->array[0];
}
if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type)
&& !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) {
scheme_signal_error("internal error: not a lambda for case-lambda: %d",
SCHEME_TYPE(le));
}
seq->array[i] = le;
}
if (!SCHEME_NULLP(clears)) {
return scheme_sfs_add_clears(expr, clears, 0);
} else
return expr;
}
static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info)
{
Scheme_Letrec *lr = (Scheme_Letrec *)o;
Scheme_Object **procs, *v, *clears = scheme_null;
int i, count;
count = lr->count;
scheme_sfs_start_sequence(info, count + 1, 1);
procs = lr->procs;
for (i = 0; i < count; i++) {
v = scheme_sfs_expr(procs[i], info, i);
if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) {
/* Some clearing actions were added to the closure.
Lift them out. */
int j;
Scheme_Sequence *cseq = (Scheme_Sequence *)v;
for (j = 1; j < cseq->count; j++) {
int pos;
pos = SCHEME_LOCAL_POS(cseq->array[j]);
clears = scheme_make_pair(scheme_make_integer(pos), clears);
}
v = cseq->array[0];
}
procs[i] = v;
}
v = scheme_sfs_expr(lr->body, info, -1);
v = scheme_sfs_add_clears(v, clears, 1);
lr->body = v;
return o;
}
static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip,
Scheme_Object *vec, int delta,
Scheme_Object *tbranch)
{
int t_min_t, t_max_t, t_cnt, n, stackpos, i, save_nt, b_end, nt;
Scheme_Object *t_vec, *o;
Scheme_Object *clears = scheme_null;
info->min_touch = -1;
info->max_touch = -1;
save_nt = info->max_nontail;
SFS_LOG(printf("%d %d %s %d\n", info->pass, ip, (delta ? "else" : "then"), ip));
if (info->pass) {
/* Re-install max_used entries that refer to the branch */
o = SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W];
t_min_t = SCHEME_INT_VAL(o);
o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2];
nt = SCHEME_INT_VAL(o);
if (nt > info->max_nontail)
info->max_nontail = nt;
if (t_min_t > -1) {
t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1];
t_cnt = SCHEME_VEC_SIZE(t_vec);
for (i = 0; i < t_cnt; i++) {
o = SCHEME_VEC_ELS(t_vec)[i];
if (SCHEME_INTP(o)) {
n = SCHEME_INT_VAL(o);
SFS_LOG(printf(" @%d %d\n", i + t_min_t, n));
if (info->max_used[i + t_min_t] < n) {
SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail));
info->max_used[i + t_min_t] = n;
info->max_calls[i + t_min_t] = info->max_nontail;
}
}
}
}
/* If the other branch has last use for something not used in this
branch, and if there's a non-tail call in this branch
of later, then we'll have to start with explicit clears.
Note that it doesn't matter whether the other branch actually
clears them (i.e., the relevant non-tail call might be only
in this branch). */
o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3];
b_end = SCHEME_INT_VAL(o);
SFS_LOG(printf(" %d %d %d %d\n", nt, ip, b_end, save_nt));
if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */
|| ((ip + 1) < save_nt)) { /* => non-tail call after branches */
SFS_LOG(printf(" other\n"));
o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W];
t_min_t = SCHEME_INT_VAL(o);
if (t_min_t > -1) {
int at_ip, pos;
t_vec = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 1];
t_cnt = SCHEME_VEC_SIZE(t_vec);
o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 2];
nt = SCHEME_INT_VAL(o);
o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 3];
b_end = SCHEME_INT_VAL(o);
for (i = 0; i < t_cnt; i++) {
o = SCHEME_VEC_ELS(t_vec)[i];
if (SCHEME_INTP(o)) {
n = SCHEME_INT_VAL(o);
pos = i + t_min_t;
at_ip = info->max_used[pos];
SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip));
/* is last use in other branch? */
if (((!delta && (at_ip == ip))
|| (delta && (at_ip == n)))) {
/* Yes, so add clear */
SFS_LOG(printf(" !%d %d %d\n", pos, n, at_ip));
pos -= info->stackpos;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
}
}
}
}
stackpos = info->stackpos;
tbranch = scheme_sfs_expr(tbranch, info, -1);
if (info->pass)
info->max_nontail = save_nt;
# if MAX_SFS_CLEARING
else
info->max_nontail = info->ip;
# endif
tbranch = scheme_sfs_add_clears(tbranch, clears, 1);
if (!info->pass) {
t_min_t = info->min_touch;
t_max_t = info->max_touch;
if (t_min_t < stackpos)
t_min_t = stackpos;
if (t_max_t < stackpos)
t_max_t = -1;
SFS_LOG(printf("%d %s %d [%d,%d] /%d\n", info->pass, (delta ? "else" : "then"), ip,
t_min_t, t_max_t, stackpos));
if (t_max_t < 0) {
t_min_t = -1;
t_vec = scheme_false;
} else {
t_cnt = t_max_t - t_min_t + 1;
t_vec = scheme_make_vector(t_cnt, NULL);
for (i = 0; i < t_cnt; i++) {
n = info->max_used[i + t_min_t];
SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip,
i + t_min_t, n, info->max_calls[i+ t_min_t]));
if (n > ip) {
SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n);
info->max_used[i + t_min_t] = ip;
} else {
SCHEME_VEC_ELS(t_vec)[i] = scheme_false;
}
}
}
SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W] = scheme_make_integer(t_min_t);
SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1] = t_vec;
SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2] = scheme_make_integer(info->max_nontail);
SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3] = scheme_make_integer(info->ip);
}
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;
return tbranch;
}
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;
}