static Scheme_Object *
define_values_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *e;
scheme_sfs_start_sequence(info, 1, 0);
e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1);
SCHEME_VEC_ELS(data)[0] = e;
return data;
}
static Scheme_Object *
inline_variant_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *e;
scheme_sfs_start_sequence(info, 1, 0);
e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1);
SCHEME_VEC_ELS(data)[0] = e;
/* we don't bother with inlinable variant, since it isn't called directly */
return data;
}
static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b, *vec;
int pos, save_mnt;
scheme_sfs_start_sequence(info, 3, 1);
k = scheme_sfs_expr(wcm->key, info, -1);
v = scheme_sfs_expr(wcm->val, info, -1);
scheme_sfs_push(info, 1, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
b = scheme_sfs_expr(wcm->body, info, -1);
wcm->key = k;
wcm->val = v;
wcm->body = b;
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
}
return o;
}
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 *
begin0_sfs(Scheme_Object *obj, SFS_Info *info)
{
int i, cnt;
cnt = ((Scheme_Sequence *)obj)->count;
scheme_sfs_start_sequence(info, cnt, 0);
for (i = 0; i < cnt; i++) {
Scheme_Object *le;
le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1);
((Scheme_Sequence *)obj)->array[i] = le;
}
return obj;
}
static Scheme_Object *sfs_wcm(Scheme_Object *o, SFS_Info *info)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b;
scheme_sfs_start_sequence(info, 3, 1);
k = scheme_sfs_expr(wcm->key, info, -1);
v = scheme_sfs_expr(wcm->val, info, -1);
b = scheme_sfs_expr(wcm->body, info, -1);
wcm->key = k;
wcm->val = v;
wcm->body = b;
return o;
}
static Scheme_Object *
module_sfs(Scheme_Object *data, SFS_Info *old_info)
{
Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *e, *ex;
SFS_Info *info;
int i, j, cnt, let_depth;
if (!old_info->for_mod) {
if (old_info->pass)
return data;
info = scheme_new_sfs_info(m->max_let_depth);
info->for_mod = 1;
scheme_sfs(data, info, m->max_let_depth);
return data;
}
info = old_info;
cnt = SCHEME_VEC_SIZE(m->bodies[0]);
scheme_sfs_start_sequence(info, cnt, 0);
for (i = 0; i < cnt; i++) {
e = scheme_sfs_expr(SCHEME_VEC_ELS(m->bodies[0])[i], info, -1);
SCHEME_VEC_ELS(m->bodies[0])[i] = e;
}
if (!info->pass) {
for (j = m->num_phases; j-- > 1; ) {
cnt = SCHEME_VEC_SIZE(m->bodies[j]);
for (i = 0; i < cnt; i++) {
e = SCHEME_VEC_ELS(m->bodies[j])[i];
let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]);
ex = SCHEME_VEC_ELS(e)[1];
info = scheme_new_sfs_info(let_depth);
ex = scheme_sfs(ex, info, let_depth);
SCHEME_VEC_ELS(e)[1] = ex;
}
}
}
return 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 *
set_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data;
Scheme_Object *var, *val;
var = sb->var;
val = sb->val;
scheme_sfs_start_sequence(info, 2, 0);
val = scheme_sfs_expr(val, info, -1);
var = scheme_sfs_expr(var, info, -1);
sb->var = var;
sb->val = val;
return (Scheme_Object *)sb;
}
static Scheme_Object *sfs_application2(Scheme_Object *o, SFS_Info *info)
{
Scheme_App2_Rec *app;
Scheme_Object *nrator, *nrand;
app = (Scheme_App2_Rec *)o;
scheme_sfs_start_sequence(info, 2, 0);
scheme_sfs_push(info, 1, 0);
nrator = scheme_sfs_expr(app->rator, info, -1);
nrand = scheme_sfs_expr(app->rand, info, -1);
app->rator = nrator;
app->rand = nrand;
sfs_note_app(info, app->rator);
scheme_reset_app2_eval_type(app);
return o;
}
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_sequence(Scheme_Object *o, SFS_Info *info, int can_flatten)
{
Scheme_Object *orig, *naya;
Scheme_Sequence *seq;
int i, n;
seq = (Scheme_Sequence *)o;
n = seq->count;
scheme_sfs_start_sequence(info, n, 1);
for (i = 0; i < n; i++) {
orig = seq->array[i];
naya = scheme_sfs_expr(orig, info, -2);
seq->array[i] = naya;
}
if (can_flatten && info->pass)
o = flatten_sequence(o);
return o;
}
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_application(Scheme_Object *o, SFS_Info *info)
{
Scheme_Object *orig, *naya = NULL;
Scheme_App_Rec *app;
int i, n;
app = (Scheme_App_Rec *)o;
n = app->num_args + 1;
scheme_sfs_start_sequence(info, n, 0);
scheme_sfs_push(info, n-1, 0);
for (i = 0; i < n; i++) {
orig = app->args[i];
naya = scheme_sfs_expr(orig, info, -1);
app->args[i] = naya;
}
sfs_note_app(info, app->args[0]);
scheme_finish_application(app);
return o;
}
static Scheme_Object *sfs_application3(Scheme_Object *o, SFS_Info *info)
{
Scheme_App3_Rec *app;
Scheme_Object *nrator, *nrand1, *nrand2;
app = (Scheme_App3_Rec *)o;
scheme_sfs_start_sequence(info, 3, 0);
scheme_sfs_push(info, 2, 0);
nrator = scheme_sfs_expr(app->rator, info, -1);
nrand1 = scheme_sfs_expr(app->rand1, info, -1);
nrand2 = scheme_sfs_expr(app->rand2, info, -1);
app->rator = nrator;
app->rand1 = nrand1;
app->rand2 = nrand2;
sfs_note_app(info, app->rator);
scheme_reset_app3_eval_type(app);
return o;
}
static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_One *lo = (Scheme_Let_One *)o;
Scheme_Object *body, *rhs, *vec;
int pos, save_mnt, ip, et;
int unused = 0;
scheme_sfs_start_sequence(info, 2, 1);
scheme_sfs_push(info, 1, 1);
ip = info->ip;
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
rhs = scheme_sfs_expr(lo->value, info, -1);
body = scheme_sfs_expr(lo->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
if (info->max_used[pos] <= ip) {
/* No one is using it, so don't actually push the value at run time
(but keep the check that the result is single-valued).
The optimizer normally would have converted away the binding, but
it might not because (1) it was introduced late by inlining,
or (2) the rhs expression doesn't always produce a single
value. */
if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) {
rhs = scheme_false;
} else if ((ip < info->max_calls[pos])
&& SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {
/* Unusual case: we can't just drop the global-variable access,
because it might be undefined, but we don't need the value,
and we want to avoid an SFS clear in the interpreter loop.
So, bind #f and then access in the global in a `begin'. */
Scheme_Sequence *s;
s = scheme_malloc_sequence(2);
s->so.type = scheme_sequence_type;
s->count = 2;
s->array[0] = rhs;
s->array[1] = body;
body = (Scheme_Object *)s;
rhs = scheme_false;
}
unused = 1;
}
}
lo->value = rhs;
lo->body = body;
et = scheme_get_eval_type(lo->value);
SCHEME_LET_EVAL_TYPE(lo) = (et
| (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM))
| (unused ? LET_ONE_UNUSED : 0));
return o;
}
static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info)
{
Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb, *vec;
int ip, min_t, max_t;
b = (Scheme_Branch_Rec *)o;
scheme_sfs_start_sequence(info, 1, 0);
t = scheme_sfs_expr(b->test, info, -1);
ip = info->ip;
info->ip++;
/* Use ip to represent all uses in the two branches.
Use ip+1 to represent all non-tail calls in the two branches. */
min_t = info->min_touch;
max_t = info->max_touch;
SFS_LOG(printf(" after test: %d %d\n", min_t, max_t));
if (!info->pass) {
vec = scheme_make_vector(SFS_BRANCH_W * 2, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
}
tb = sfs_one_branch(info, ip, vec, 0, b->tbranch);
if (!info->pass) {
if ((min_t == -1)
|| ((info->min_touch > -1) && (info->min_touch < min_t)))
min_t = info->min_touch;
if (info->max_touch > max_t)
max_t = info->max_touch;
if (info->max_nontail > ip + 1)
info->max_nontail = ip + 1;
}
fb = sfs_one_branch(info, ip, vec, 1, b->fbranch);
if (!info->pass) {
if ((min_t == -1)
|| ((info->min_touch > -1) && (info->min_touch < min_t)))
min_t = info->min_touch;
if (info->max_touch > max_t)
max_t = info->max_touch;
if (info->max_nontail > ip + 1)
info->max_nontail = ip + 1;
}
SFS_LOG(printf(" done if: %d %d\n", min_t, max_t));
info->min_touch = min_t;
info->max_touch = max_t;
b->test = t;
b->tbranch = tb;
b->fbranch = fb;
return o;
}
