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; }