EVAL_INLINE void fstack_enter_eval_frame(lref_t *form, lref_t fop, lref_t env) {
lref_t *frame = fstack_enter_frame(FRAME_EVAL, 3);
frame[FOFS_EVAL_FORM_PTR] = (lref_t)form;
frame[FOFS_EVAL_IFORM] = fop;
frame[FOFS_EVAL_ENV] = env;
}
EVAL_INLINE jmp_buf *fstack_enter_catch_frame(lref_t tag, lref_t *escape_frame) {
lref_t *frame = fstack_enter_frame(FRAME_ESCAPE, 3);
frame[FOFS_ESCAPE_TAG] = tag;
frame[FOFS_ESCAPE_FRAME] = (lref_t)CURRENT_TIB()->frame;
frame[FOFS_ESCAPE_JMPBUF_PTR] = (lref_t)fstack_alloca(sizeof(jmp_buf));
return (jmp_buf *)frame[FOFS_ESCAPE_JMPBUF_PTR];
}
EVAL_INLINE lref_t subr_apply(lref_t function, size_t argc, lref_t argv[], lref_t * env, lref_t * retval)
{
lref_t arg1;
lref_t args;
size_t ii;
UNREFERENCED(env);
fstack_enter_frame(FRAME_SUBR);
fstack_push((lref_t)function);
switch (SUBR_TYPE(function))
{
case SUBR_0:
*retval = (SUBR_F0(function) ());
break;
case SUBR_1:
*retval = (SUBR_F1(function) (_ARGV(0)));
break;
case SUBR_2:
*retval = (SUBR_F2(function) (_ARGV(0), _ARGV(1)));
break;
case SUBR_3:
*retval = (SUBR_F3(function) (_ARGV(0), _ARGV(1), _ARGV(2)));
break;
case SUBR_4:
*retval = (SUBR_F4(function) (_ARGV(0), _ARGV(1), _ARGV(2), _ARGV(3)));
break;
case SUBR_2N:
arg1 = _ARGV(0);
arg1 = SUBR_F2(function) (arg1, _ARGV(1));
for (ii = 2; ii < argc; ii++)
arg1 = SUBR_F2(function) (arg1, _ARGV(ii));
*retval = arg1;
break;
case SUBR_ARGC:
*retval = (SUBR_FARGC(function) (argc, argv));
break;
case SUBR_N:
args = arg_list_from_buffer(argc, argv);
*retval = (SUBR_F1(function) (args));
break;
}
fstack_leave_frame();
return NIL;
}
EVAL_INLINE void fstack_enter_unwind_frame(lref_t unwind_after) {
lref_t *frame = fstack_enter_frame(FRAME_UNWIND, 1);
frame[FOFS_UNWIND_AFTER] = unwind_after;
}
EVAL_INLINE void fstack_enter_boundary_frame(lref_t sym) {
lref_t *frame = fstack_enter_frame(FRAME_STACK_BOUNDARY, 1);
frame[FOFS_BOUNDARY_TAG] = sym;
}
EVAL_INLINE void fstack_enter_subr_frame(lref_t subr) {
lref_t *frame = fstack_enter_frame(FRAME_SUBR, 1);
frame[FOFS_SUBR_SUBR] = subr;
}
static lref_t execute_fast_op(lref_t fop, lref_t env)
{
lref_t retval = NIL;
lref_t sym;
lref_t binding;
lref_t fn;
lref_t args;
size_t argc;
lref_t argv[ARG_BUF_LEN];
lref_t after;
lref_t tag;
lref_t cell;
lref_t escape_retval;
lref_t *jmpbuf_ptr;
jmp_buf *jmpbuf;
STACK_CHECK(&fop);
fstack_enter_frame(FRAME_EVAL);
fstack_push((lref_t)&fop);
fstack_push((lref_t)fop);
fstack_push((lref_t)env);
while(!NULLP(fop)) {
CURRENT_TIB()->count_fop++;
_process_interrupts();
#if defined(WITH_FOPLOG_SUPPORT)
if (CURRENT_TIB()->foplog_enable) {
CURRENT_TIB()->foplog[CURRENT_TIB()->foplog_index] = fop;
CURRENT_TIB()->foplog_index = (CURRENT_TIB()->foplog_index + 1) % FOPLOG_SIZE;
}
#endif
switch(fop->header.opcode)
{
case FOP_LITERAL:
retval = fop->as.fast_op.arg1;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_REF:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
retval = binding;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_SET:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, retval);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF:
sym = fop->as.fast_op.arg1;
binding = lenvlookup(sym, env);
retval = CAR(binding);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_SET:
sym = fop->as.fast_op.arg1;
binding = lenvlookup(sym, env);
SET_CAR(binding, retval);
fop = fop->as.fast_op.next;
break;
case FOP_APPLY_GLOBAL:
sym = fop->as.fast_op.arg1;
fn = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(fn))
vmerror_unbound(sym);
argc = 0;
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_APPLY:
argc = 0;
fn = execute_fast_op(fop->as.fast_op.arg1, env);
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_IF_TRUE:
if (TRUEP(retval))
fop = fop->as.fast_op.arg1;
else
fop = fop->as.fast_op.arg2;
break;
case FOP_RETVAL:
fop = fop->as.fast_op.next;
break;
case FOP_SEQUENCE:
retval = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.arg2;
break;
case FOP_THROW:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
escape_retval = execute_fast_op(fop->as.fast_op.arg2, env);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a :~a\n"), tag, escape_retval));
CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag);
CURRENT_TIB()->escape_value = escape_retval;
if (CURRENT_TIB()->escape_frame == NULL) {
/* If we don't find a matching catch for the throw, we have a
* problem and need to invoke a trap. */
vmtrap(TRAP_UNCAUGHT_THROW,
(enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE),
2, tag, escape_retval);
}
unwind_stack_for_throw();
fop = fop->as.fast_op.next;
break;
case FOP_CATCH:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
fstack_enter_frame(FRAME_ESCAPE);
fstack_push((lref_t)tag);
fstack_push((lref_t)CURRENT_TIB()->frame);
fstack_push(NIL);
jmpbuf_ptr = CURRENT_TIB()->fsp;
jmpbuf = (jmp_buf *)fstack_alloca(sizeof(jmp_buf));
*(jmpbuf_ptr) = (lref_t)jmpbuf;
if (setjmp(*jmpbuf) == 0) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
} else {
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch retval =~a\n"), CURRENT_TIB()->escape_value));
retval = CURRENT_TIB()->escape_value;
CURRENT_TIB()->escape_value = NIL;
}
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_WITH_UNWIND_FN:
fstack_enter_frame(FRAME_UNWIND);
fstack_push((lref_t)execute_fast_op(fop->as.fast_op.arg1, env));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER];
fstack_leave_frame();
apply1(after, 0, NULL);
fop = fop->as.fast_op.next;
break;
case FOP_CLOSURE:
retval = lclosurecons(env,
lcons(lcar(fop->as.fast_op.arg1),
fop->as.fast_op.arg2),
lcdr(fop->as.fast_op.arg1));
fop = fop->as.fast_op.next;
break;
case FOP_CAR:
retval = lcar(retval);
fop = fop->as.fast_op.next;
break;
case FOP_CDR:
retval = lcdr(retval);
fop = fop->as.fast_op.next;
break;
case FOP_NOT:
retval = boolcons(!TRUEP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_NULLP:
retval = boolcons(NULLP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_EQP:
retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env),
execute_fast_op(fop->as.fast_op.arg2, env)));
fop = fop->as.fast_op.next;
break;
case FOP_GET_ENV:
retval = env;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused
retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FSP:
retval = fixcons((fixnum_t)CURRENT_TIB()->fsp);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FRAME:
retval = fixcons((fixnum_t)CURRENT_TIB()->frame);
fop = fop->as.fast_op.next;
break;
case FOP_GET_HFRAMES:
retval = CURRENT_TIB()->handler_frames;
fop = fop->as.fast_op.next;
break;
case FOP_SET_HFRAMES:
CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_PRESERVE_FRAME:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fop = fop->as.fast_op.next;
break;
case FOP_STACK_BOUNDARY:
sym = execute_fast_op(fop->as.fast_op.arg1, env);
fstack_enter_frame(FRAME_STACK_BOUNDARY);
fstack_push((lref_t)sym);
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_FAST_ENQUEUE_CELL:
retval = execute_fast_op(fop->as.fast_op.arg2, env);
cell = execute_fast_op(fop->as.fast_op.arg1, env);
SET_CDR(CAR(retval), cell);
SET_CAR(retval, cell);
fop = fop->as.fast_op.next;
break;
case FOP_WHILE_TRUE:
while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
}
fop = fop->as.fast_op.next;
break;
default:
panic("Unsupported fast-op");
}
}
fstack_leave_frame();
return retval;
}
