static Scheme_Object *define_values_jit(Scheme_Object *data)
{
Scheme_Object *orig = SCHEME_DEFN_RHS(data), *naya;
if (SAME_TYPE(SCHEME_TYPE(orig), scheme_lambda_type)
&& (SCHEME_DEFN_VAR_COUNT(data) == 1))
naya = scheme_jit_closure(orig, SCHEME_DEFN_VAR_(data, 0));
else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_lambda_type)
&& (SCHEME_DEFN_VAR_COUNT(data) == 1)) {
naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_DEFN_VAR_(data, 0));
if (!SAME_OBJ(naya, SCHEME_DEFN_RHS(orig)))
naya = clone_inline_variant(orig, naya);
} else
naya = jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else {
orig = naya;
naya = scheme_clone_vector(data, 0, 1);
SCHEME_DEFN_RHS(naya) = orig;
return naya;
}
}
static Scheme_Object *define_values_jit(Scheme_Object *data)
{
Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya;
if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type)
&& (SCHEME_VEC_SIZE(data) == 2))
naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]);
else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_unclosed_procedure_type)
&& (SCHEME_VEC_SIZE(data) == 2)) {
naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_VEC_ELS(data)[1]);
if (!SAME_OBJ(naya, SCHEME_VEC_ELS(orig)[0]))
naya = clone_inline_variant(orig, naya);
} else
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else {
orig = naya;
naya = scheme_clone_vector(data, 0, 1);
SCHEME_VEC_ELS(naya)[0] = orig;
return naya;
}
}
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) {
if (argc == 1) {
Scheme_Object *mso;
Scheme_Place_Bi_Channel *ch;
if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
}
else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
ch = (Scheme_Place_Bi_Channel *) args[0];
}
else {
ch = NULL;
scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args);
}
{
void *msg_memory = NULL;
mso = scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch, &msg_memory);
return scheme_places_deserialize(mso, msg_memory);
}
}
else {
scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0);
}
return scheme_true;
}
static Scheme_Object *read_sequence_splice(Scheme_Object *obj)
{
obj = scheme_make_sequence_compilation(obj, 1);
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type))
obj->type = scheme_splice_sequence_type;
return obj;
}
static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
{
if (!info->pass) {
if (!info->tail_pos) {
if (SAME_OBJ(scheme_values_func, rator))
/* no need to clear for app of `values' */
return;
if (SCHEME_PRIMP(rator)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
/* Don't need to clear stack before an immediate/folding call */
return;
}
info->max_nontail = info->ip;
} else {
if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) {
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) {
if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
/* No point in clearing out any of the closure before the
tail call. */
int i;
for (i = info->selflen; i--; ) {
if ((info->selfstart + i) != info->tlpos)
scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
}
}
}
}
}
}
}
intptr_t BTC_get_memory_use(NewGC* gc, void *o)
{
Scheme_Object *arg = (Scheme_Object*)o;
if(SAME_TYPE(SCHEME_TYPE(arg), scheme_custodian_type)) {
return custodian_usage(gc, arg);
}
return 0;
}
static int scheme_place_channel_ready(Scheme_Object *so) {
Scheme_Place_Bi_Channel *ch;
if (SAME_TYPE(SCHEME_TYPE(so), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) so)->channel;
}
else {
ch = (Scheme_Place_Bi_Channel *)so;
}
return scheme_place_async_ch_ready((Scheme_Place_Async_Channel *) ch->recvch);
}
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) {
if (argc == 1) {
Scheme_Place_Bi_Channel *ch;
if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
}
else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
ch = (Scheme_Place_Bi_Channel *) args[0];
}
else {
ch = NULL;
scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args);
}
return scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch);
}
else {
scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0);
}
return scheme_true;
}
Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]) {
if (argc == 2) {
Scheme_Place_Bi_Channel *ch;
if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
}
else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
ch = (Scheme_Place_Bi_Channel *) args[0];
}
else {
ch = NULL;
scheme_wrong_type("place-channel-send", "place-channel", 0, argc, args);
}
scheme_place_async_send((Scheme_Place_Async_Channel *) ch->sendch, args[1]);
}
else {
scheme_wrong_count_m("place-channel-send", 2, 2, argc, args, 0);
}
return scheme_true;
}
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 *flatten_sequence(Scheme_Object *o)
{
/* At this point, we sometimes have (begin ... (begin ... (begin ...))).
Flatten those out. */
Scheme_Sequence *s = (Scheme_Sequence *)o, *s2;
int i, extra = 0;
o = s->array[s->count - 1];
while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
s2 = (Scheme_Sequence *)o;
extra += s2->count - 1;
o = s2->array[s2->count - 1];
}
if (extra) {
s2 = scheme_malloc_sequence(s->count + extra);
s2->so.type = scheme_sequence_type;
s2->count = s->count + extra;
extra = 0;
o = (Scheme_Object *)s;
while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
s = (Scheme_Sequence *)o;
for (i = 0; i < s->count - 1; i++) {
s2->array[extra++] = s->array[i];
}
o = s->array[i];
}
s2->array[extra++] = o;
if (extra != s2->count) scheme_signal_error("internal error: flatten failed");
return (Scheme_Object *)s2;
} else
return (Scheme_Object *)s;
}
static int scheme_place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo) {
Scheme_Place_Bi_Channel *ch;
Scheme_Object *msg = NULL;
if (SAME_TYPE(SCHEME_TYPE(so), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) so)->channel;
}
else {
ch = (Scheme_Place_Bi_Channel *)so;
}
msg = scheme_place_async_try_recv((Scheme_Place_Async_Channel *) ch->recvch);
if (msg != NULL) {
scheme_set_sync_target(sinfo, msg, NULL, NULL, 0, 0, NULL);
return 1;
}
return 0;
}
static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit)
{
Resolve_Prefix *rp, *orig_rp;
Scheme_Object *naya, *rhs;
rhs = SCHEME_VEC_ELS(expr)[0];
#ifdef MZ_USE_JIT
if (jit) {
if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type))
naya = scheme_jit_expr(rhs);
else {
int changed = 0;
Scheme_Object *a, *l = rhs;
naya = scheme_null;
while (!SCHEME_NULLP(l)) {
a = scheme_jit_expr(SCHEME_CAR(l));
if (!SAME_OBJ(a, SCHEME_CAR(l)))
changed = 1;
naya = scheme_make_pair(a, naya);
l = SCHEME_CDR(l);
}
if (changed)
naya = scheme_reverse(naya);
else
naya = rhs;
}
} else
#endif
naya = rhs;
orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
rp = scheme_prefix_eval_clone(orig_rp);
if (SAME_OBJ(naya, rhs)
&& SAME_OBJ(orig_rp, rp))
return expr;
else {
expr = scheme_clone_vector(expr, 0, 1);
SCHEME_VEC_ELS(expr)[0] = naya;
SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
return expr;
}
}
static Scheme_Object *read_case_lambda(Scheme_Object *obj)
{
Scheme_Object *s, *a;
int count, i, all_closed = 1;
Scheme_Case_Lambda *cl;
if (!SCHEME_PAIRP(obj)) return NULL;
s = SCHEME_CDR(obj);
for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) {
count++;
}
cl = (Scheme_Case_Lambda *)
scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
+ (count - 1) * sizeof(Scheme_Object *));
cl->so.type = scheme_case_lambda_sequence_type;
cl->count = count;
cl->name = SCHEME_CAR(obj);
if (SCHEME_NULLP(cl->name))
cl->name = NULL;
s = SCHEME_CDR(obj);
for (i = 0; i < count; i++, s = SCHEME_CDR(s)) {
a = SCHEME_CAR(s);
cl->array[i] = a;
if (!SCHEME_PROCP(a)) {
if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type))
return NULL;
all_closed = 0;
}
}
if (all_closed) {
/* Empty closure: produce procedure value directly.
(We assume that this was generated by a direct write of
a case-lambda data record in print.c, and that it's not
in a CASE_LAMBDA_EXPD syntax record.) */
return scheme_case_lambda_execute((Scheme_Object *)cl);
}
return (Scheme_Object *)cl;
}
static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) {
Scheme_Place *place;
place = (Scheme_Place *) args[0];
if (argc != 1) {
scheme_wrong_count_m("place-wait", 1, 1, argc, args, 0);
}
if (!SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
scheme_wrong_type("place-wait", "place", 0, argc, args);
}
# ifdef MZ_PRECISE_GC
{
Scheme_Object *rc;
mz_proc_thread *worker_thread;
Scheme_Place *waiting_place;
int *wake_fd;
proc_thread_wait_data *wd;
wd = (proc_thread_wait_data*) malloc(sizeof(proc_thread_wait_data));
wd->proc_thread = (mz_proc_thread *)place->proc_thread;
wd->waiting_place = waiting_place;
wake_fd = scheme_get_signal_handle();
wd->wake_fd = wake_fd;
wd->ready = 0;
worker_thread = mz_proc_thread_create(mz_proc_thread_wait_worker, wd);
mz_proc_thread_detach(worker_thread);
scheme_block_until(place_wait_ready, NULL, (Scheme_Object *) wd, 0);
rc = scheme_make_integer((intptr_t)wd->rc);
free(wd);
return rc;
}
# else
{
void *rcvoid;
rcvoid = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread);
return scheme_make_integer((intptr_t) rcvoid);
}
# endif
}
static void get_outof_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w)
{
Scheme_Channel_Syncer *last, *first;
if (!w->in_line)
return;
w->in_line = 0;
if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
return; /* !!!! skip everything else */
} else if (SCHEME_SEMAP(sema)) {
last = sema->last;
first = sema->first;
} else if (SCHEME_CHANNELP(sema)) {
last = ((Scheme_Channel *)sema)->get_last;
first = ((Scheme_Channel *)sema)->get_first;
} else {
last = ((Scheme_Channel_Put *)sema)->ch->put_last;
first = ((Scheme_Channel_Put *)sema)->ch->put_first;
}
if (w->prev)
w->prev->next = w->next;
else
first = w->next;
if (w->next)
w->next->prev = w->prev;
else
last = w->prev;
if (SCHEME_SEMAP(sema)) {
sema->last = last;
sema->first = first;
} else if (SCHEME_CHANNELP(sema)) {
((Scheme_Channel *)sema)->get_last = last;
((Scheme_Channel *)sema)->get_first = first;
} else {
((Scheme_Channel_Put *)sema)->ch->put_last = last;
((Scheme_Channel_Put *)sema)->ch->put_first = first;
}
}
static void get_into_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w)
/* Can be called multiple times. */
{
Scheme_Channel_Syncer *last, *first;
w->in_line = 1;
w->picked = 0;
if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
return; /* !!!! skip everything else */
} else if (SCHEME_SEMAP(sema)) {
last = sema->last;
first = sema->first;
} else if (SCHEME_CHANNELP(sema)) {
last = ((Scheme_Channel *)sema)->get_last;
first = ((Scheme_Channel *)sema)->get_first;
} else {
last = ((Scheme_Channel_Put *)sema)->ch->put_last;
first = ((Scheme_Channel_Put *)sema)->ch->put_first;
}
w->prev = last;
if (last)
last->next = w;
else
first = w;
last = w;
w->next = NULL;
if (SCHEME_SEMAP(sema)) {
sema->last = last;
sema->first = first;
} else if (SCHEME_CHANNELP(sema)) {
((Scheme_Channel *)sema)->get_last = last;
((Scheme_Channel *)sema)->get_first = first;
} else {
((Scheme_Channel_Put *)sema)->ch->put_last = last;
((Scheme_Channel_Put *)sema)->ch->put_first = first;
}
}
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 void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
Place_Start_Data *place_data;
Scheme_Object *place_main;
Scheme_Object *a[2], *channel;
mzrt_thread_id ptid;
intptr_t rc = 0;
ptid = mz_proc_thread_self();
place_data = (Place_Start_Data *) data_arg;
data_arg = NULL;
/* printf("Startin place: proc thread id%u\n", ptid); */
/* create pristine THREAD_LOCAL variables*/
null_out_runtime_globals();
/* scheme_make_thread behaves differently if the above global vars are not null */
scheme_place_instance_init(stack_base);
a[0] = scheme_places_deep_copy(place_data->current_library_collection_paths);
scheme_current_library_collection_paths(1, a);
a[0] = scheme_places_deep_copy(place_data->module);
a[1] = scheme_places_deep_copy(place_data->function);
a[1] = scheme_intern_exact_symbol(SCHEME_SYM_VAL(a[1]), SCHEME_SYM_LEN(a[1]));
if (!SAME_TYPE(SCHEME_TYPE(place_data->channel), scheme_place_bi_channel_type)) {
channel = scheme_places_deep_copy(place_data->channel);
}
else {
channel = place_data->channel;
}
mzrt_sema_post(place_data->ready);
place_data = NULL;
# ifdef MZ_PRECISE_GC
/* this prevents a master collection attempt from deadlocking with the
place_data->ready semaphore above */
GC_allow_master_gc_check();
# endif
/* at point point, don't refer to place_data or its content
anymore, because it's allocated in the other place */
scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_place_exit_proc);
{
Scheme_Thread * volatile p;
mz_jmp_buf * volatile saved_error_buf;
mz_jmp_buf new_error_buf;
p = scheme_get_current_thread();
saved_error_buf = p->error_buf;
p->error_buf = &new_error_buf;
if (!scheme_setjmp(new_error_buf)) {
Scheme_Object *dynamic_require;
dynamic_require = scheme_builtin_value("dynamic-require");
place_main = scheme_apply(dynamic_require, 2, a);
a[0] = channel;
scheme_apply(place_main, 1, a);
}
else {
rc = 1;
}
p->error_buf = saved_error_buf;
}
/*printf("Leavin place: proc thread id%u\n", ptid);*/
scheme_place_instance_destroy();
return (void*) rc;
}
static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[])
{
return SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type) ? scheme_true : scheme_false;
}
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 *is_sema_repost(int n, Scheme_Object **p)
{
return (SAME_TYPE(SCHEME_TYPE(p[0]), scheme_semaphore_repost_type)
? scheme_true
: scheme_false);
}
Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos)
/* closure_self_pos == -2 => immediately in sequence */
{
Scheme_Type type = SCHEME_TYPE(expr);
int seqn, stackpos, tp;
seqn = info->seqn;
stackpos = info->stackpos;
tp = info->tail_pos;
if (seqn) {
info->seqn = 0;
info->tail_pos = 0;
}
info->ip++;
switch (type) {
case scheme_local_type:
case scheme_local_unbox_type:
if (!info->pass)
scheme_sfs_used(info, SCHEME_LOCAL_POS(expr));
else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) {
int pos, at_ip;
pos = SCHEME_LOCAL_POS(expr);
at_ip = info->max_used[info->stackpos + pos];
if (at_ip < info->max_calls[info->stackpos + pos]) {
if (at_ip == info->ip) {
/* Clear on read: */
expr = scheme_make_local(type, pos, SCHEME_LOCAL_CLEAR_ON_READ);
} else {
/* Someone else clears it: */
expr = scheme_make_local(type, pos, SCHEME_LOCAL_OTHER_CLEARS);
}
} else {
# if MAX_SFS_CLEARING
scheme_signal_error("should have been cleared somewhere");
# endif
}
}
break;
case scheme_application_type:
expr = sfs_application(expr, info);
break;
case scheme_application2_type:
expr = sfs_application2(expr, info);
break;
case scheme_application3_type:
expr = sfs_application3(expr, info);
break;
case scheme_sequence_type:
expr = sfs_sequence(expr, info, closure_self_pos != -2);
break;
case scheme_splice_sequence_type:
expr = sfs_sequence(expr, info, 0);
break;
case scheme_branch_type:
expr = sfs_branch(expr, info);
break;
case scheme_with_cont_mark_type:
expr = sfs_wcm(expr, info);
break;
case scheme_unclosed_procedure_type:
expr = sfs_closure(expr, info, closure_self_pos);
break;
case scheme_let_value_type:
expr = sfs_let_value(expr, info);
break;
case scheme_let_void_type:
expr = sfs_let_void(expr, info);
break;
case scheme_letrec_type:
expr = sfs_letrec(expr, info);
break;
case scheme_let_one_type:
expr = sfs_let_one(expr, info);
break;
case scheme_closure_type:
{
Scheme_Closure *c = (Scheme_Closure *)expr;
if (ZERO_SIZED_CLOSUREP(c)) {
Scheme_Object *code;
code = sfs_closure((Scheme_Object *)c->code, info, closure_self_pos);
if (SAME_TYPE(SCHEME_TYPE(code), scheme_begin0_sequence_type)) {
Scheme_Sequence *seq = (Scheme_Sequence *)code;
c->code = (Scheme_Closure_Data *)seq->array[0];
seq->array[0] = expr;
expr = code;
} else {
c->code = (Scheme_Closure_Data *)code;
}
}
}
break;
case scheme_toplevel_type:
{
int c = SCHEME_TOPLEVEL_DEPTH(expr);
if (info->stackpos + c != info->tlpos)
scheme_signal_error("toplevel access not at expected place");
}
break;
case scheme_case_closure_type:
{
/* FIXME: maybe need to handle eagerly created closure */
}
break;
case scheme_define_values_type:
expr = define_values_sfs(expr, info);
break;
case scheme_define_syntaxes_type:
expr = define_syntaxes_sfs(expr, info);
break;
case scheme_begin_for_syntax_type:
expr = begin_for_syntax_sfs(expr, info);
break;
case scheme_set_bang_type:
expr = set_sfs(expr, info);
break;
case scheme_boxenv_type:
expr = bangboxenv_sfs(expr, info);
break;
case scheme_begin0_sequence_type:
expr = begin0_sfs(expr, info);
break;
case scheme_require_form_type:
expr = top_level_require_sfs(expr, info);
break;
case scheme_varref_form_type:
expr = ref_sfs(expr, info);
break;
case scheme_apply_values_type:
expr = apply_values_sfs(expr, info);
break;
case scheme_case_lambda_sequence_type:
expr = case_lambda_sfs(expr, info);
break;
case scheme_module_type:
expr = module_sfs(expr, info);
break;
case scheme_inline_variant_type:
expr = inline_variant_sfs(expr, info);
break;
default:
break;
}
info->ip++;
if (seqn) {
info->seqn = seqn - 1;
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;
info->tail_pos = tp;
}
return expr;
}
