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 *write_compiled_closure(Scheme_Object *obj)
{
Scheme_Closure_Data *data;
Scheme_Object *name, *l, *code, *ds, *tl_map;
int svec_size, pos;
Scheme_Marshal_Tables *mt;
data = (Scheme_Closure_Data *)obj;
if (data->name) {
name = data->name;
if (SCHEME_VECTORP(name)) {
/* We can only save marshalable src names, which includes
paths, symbols, and strings: */
Scheme_Object *src;
src = SCHEME_VEC_ELS(name)[1];
if (!SCHEME_PATHP(src)
&& !SCHEME_PATHP(src)
&& !SCHEME_SYMBOLP(src)) {
/* Just keep the name */
name = SCHEME_VEC_ELS(name)[0];
}
}
} else {
name = scheme_null;
}
svec_size = data->closure_size;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
svec_size += ((2 * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT;
}
if (SCHEME_RPAIRP(data->code)) {
/* This can happen if loaded bytecode is printed out and the procedure
body has never been needed before.
It's also possible in non-JIT mode if an empty closure is embedded
as a 3-D value in compiled code. */
scheme_delay_load_closure(data);
}
/* If the body is simple enough, write it directly.
Otherwise, create a delay indirection so that the body
is loaded on demand. */
code = data->code;
switch (SCHEME_TYPE(code)) {
case scheme_toplevel_type:
case scheme_local_type:
case scheme_local_unbox_type:
case scheme_integer_type:
case scheme_true_type:
case scheme_false_type:
case scheme_void_type:
case scheme_quote_syntax_type:
ds = code;
break;
default:
ds = NULL;
break;
}
if (!ds) {
mt = scheme_current_thread->current_mt;
if (!mt->pass) {
int key;
pos = mt->cdata_counter;
if ((!mt->cdata_map || (pos >= 32))
&& !(pos & (pos - 1))) {
/* Need to grow the array */
Scheme_Object **a;
a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32));
memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *));
mt->cdata_map = a;
}
