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 *do_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *e;
if (!info->pass) {
int depth;
depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]);
info = scheme_new_sfs_info(depth);
e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth);
SCHEME_VEC_ELS(data)[0] = e;
}
return data;
}
static Scheme_Object *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *l, *a;
if (!info->pass) {
int depth;
depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]);
for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
info = scheme_new_sfs_info(depth);
a = scheme_sfs(a, info, depth);
SCHEME_CAR(l) = a;
}
}
return data;
}
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;
}
