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 *sfs_let_void(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
Scheme_Object *body;
int i, pos, save_mnt;
Scheme_Object *vec;
scheme_sfs_push(info, lv->count, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(lv->count + 1, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (!SCHEME_VECTORP(vec))
scheme_signal_error("internal error: not a vector");
for (i = 0; i < lv->count; i++) {
info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]);
info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
body = scheme_sfs_expr(lv->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail);
for (i = 0; i < lv->count; i++) {
n = info->max_used[pos + i];
SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n);
}
} else {
info->max_nontail = save_mnt;
}
lv->body = body;
return o;
}
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_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_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_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_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;
}
