#include "control.h"
#include "frames.h"
#include "instructions.h"
-#include "objcodes.h"
+#include "loader.h"
#include "programs.h"
#include "vm.h"
#include "vm-builtins.h"
necessary, but might be if you think you found a bug in the VM. */
#define VM_ENABLE_ASSERTIONS
-/* We can add a mode that ensures that all stack items above the stack pointer
- are NULL. This is useful for checking the internal consistency of the VM's
- assumptions and its operators, but isn't necessary for normal operation. It
- will ensure that assertions are enabled. Slows down the VM by about 30%. */
-/* NB! If you enable this, search for NULLING in throw.c */
-/* #define VM_ENABLE_STACK_NULLING */
-
/* #define VM_ENABLE_PARANOID_ASSERTIONS */
-#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
-#define VM_ENABLE_ASSERTIONS
-#endif
-
/* When defined, arrange so that the GC doesn't scan the VM stack beyond its
current SP. This should help avoid excess data retention. See
http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
call to vm_run; but that's currently not implemented.
*/
SCM
-scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
+scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra,
scm_t_dynstack *dynstack, scm_t_uint32 flags)
{
struct scm_vm_cont *p;
p->stack_size = sp - stack_base + 1;
p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
-#if defined(VM_ENABLE_STACK_NULLING) && 0
- /* Tail continuations leave their frame on the stack for subsequent
- application, but don't capture the frame -- so there are some elements on
- the stack then, and this check doesn't work, so disable it for now. */
- if (sp >= vp->stack_base)
- if (!vp->sp[0] || vp->sp[1])
- abort ();
- memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
-#endif
p->ra = ra;
p->sp = sp;
p->fp = fp;
}
static void
-vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
+vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
{
- struct scm_vm *vp;
struct scm_vm_cont *cp;
SCM *argv_copy;
argv_copy = alloca (n * sizeof(SCM));
memcpy (argv_copy, argv, n * sizeof(SCM));
- vp = SCM_VM_DATA (vm);
cp = SCM_VM_CONT_DATA (cont);
if (vp->stack_size < cp->stack_size + n + 3)
scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
- scm_list_2 (vm, cont));
+ scm_list_1 (cont));
-#ifdef VM_ENABLE_STACK_NULLING
- {
- scm_t_ptrdiff nzero = (vp->sp - cp->sp);
- if (nzero > 0)
- memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
- /* actually nzero should always be negative, because vm_reset_stack will
- unwind the stack to some point *below* this continuation */
- }
-#endif
vp->sp = cp->sp;
vp->fp = cp->fp;
memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
scm_i_capture_current_stack (void)
{
scm_i_thread *thread;
- SCM vm;
struct scm_vm *vp;
thread = SCM_I_CURRENT_THREAD;
- vm = scm_the_vm ();
- vp = SCM_VM_DATA (vm);
+ vp = scm_the_vm ();
return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip,
scm_dynstack_capture_all (&thread->dynstack),
0);
}
-static void vm_dispatch_hook (SCM vm, int hook_num,
- SCM *argv, int n) SCM_NOINLINE;
+static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) SCM_NOINLINE;
+static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp) SCM_NOINLINE;
static void
-vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
+vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n)
{
- struct scm_vm *vp;
SCM hook;
struct scm_frame c_frame;
scm_t_cell *frame;
int saved_trace_level;
- vp = SCM_VM_DATA (vm);
hook = vp->hooks[hook_num];
if (SCM_LIKELY (scm_is_false (hook))
while the stack frame represented by the frame object is visible, so it
seems reasonable to limit the lifetime of frame objects. */
- c_frame.stack_holder = vm;
- c_frame.fp = vp->fp;
- c_frame.sp = vp->sp;
+ c_frame.stack_holder = vp;
+ c_frame.fp_offset = vp->fp - vp->stack_base;
+ c_frame.sp_offset = vp->sp - vp->stack_base;
c_frame.ip = vp->ip;
- c_frame.offset = 0;
/* Arrange for FRAME to be 8-byte aligned, like any other cell. */
frame = alloca (sizeof (*frame) + 8);
frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
- frame->word_0 = SCM_PACK (scm_tc7_frame);
+ frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8));
frame->word_1 = SCM_PACK_POINTER (&c_frame);
if (n == 0)
}
static void
-vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+vm_dispatch_apply_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0);
+}
+static void vm_dispatch_push_continuation_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
+}
+static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK,
+ &SCM_FRAME_LOCAL (old_fp, 1),
+ SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1);
+}
+static void vm_dispatch_next_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0);
+}
+static void vm_dispatch_abort_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK,
+ &SCM_FRAME_LOCAL (vp->fp, 1),
+ SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
+}
+static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0);
+}
+
+static void
+vm_abort (struct scm_vm *vp, SCM tag,
+ size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
scm_i_jmp_buf *current_registers) SCM_NORETURN;
static void
-vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+vm_abort (struct scm_vm *vp, SCM tag,
+ size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
scm_i_jmp_buf *current_registers)
{
size_t i;
argv[i] = scm_car (tail);
/* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
- SCM_VM_DATA (vm)->sp = sp;
+ vp->sp = sp;
- scm_c_abort (vm, tag, nstack + tail_len, argv, current_registers);
+ scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers);
}
static void
-vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv,
+vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
+ size_t n, SCM *argv,
scm_t_dynstack *dynstack,
scm_i_jmp_buf *registers)
{
- struct scm_vm *vp;
struct scm_vm_cont *cp;
SCM *argv_copy, *base;
scm_t_ptrdiff reloc;
argv_copy = alloca (n * sizeof(SCM));
memcpy (argv_copy, argv, n * sizeof(SCM));
- vp = SCM_VM_DATA (vm);
cp = SCM_VM_CONT_DATA (cont);
base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
reloc = cp->reloc + (base - cp->stack_base);
if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
scm_misc_error ("vm-engine",
"not enough space to instate partial continuation",
- scm_list_2 (vm, cont));
+ scm_list_1 (cont));
memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
\f
-static SCM rtl_boot_continuation;
+static SCM vm_boot_continuation;
static SCM vm_builtin_apply;
static SCM vm_builtin_values;
static SCM vm_builtin_abort_to_prompt;
static SCM vm_builtin_call_with_values;
static SCM vm_builtin_call_with_current_continuation;
-static const scm_t_uint32 rtl_boot_continuation_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
+static const scm_t_uint32 vm_boot_continuation_code[] = {
+ SCM_PACK_OP_24 (halt, 0)
};
static const scm_t_uint32 vm_builtin_apply_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 3),
- SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0), /* proc in r1, args from r2 */
+ SCM_PACK_OP_24 (assert_nargs_ge, 3),
+ SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */
};
static const scm_t_uint32 vm_builtin_values_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+ SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
};
static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 2),
- SCM_PACK_RTL_24 (scm_rtl_op_abort, 0), /* tag in r1, vals from r2 */
+ SCM_PACK_OP_24 (assert_nargs_ge, 2),
+ SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
/* FIXME: Partial continuation should capture caller regs. */
- SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+ SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
};
static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 3),
- SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, 7),
- SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 6, 1),
- SCM_PACK_RTL_24 (scm_rtl_op_call, 6), SCM_PACK_RTL_24 (0, 1),
- SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 0, 2),
- SCM_PACK_RTL_24 (scm_rtl_op_tail_call_shuffle, 7)
+ SCM_PACK_OP_24 (assert_nargs_ee, 3),
+ SCM_PACK_OP_24 (alloc_frame, 7),
+ SCM_PACK_OP_12_12 (mov, 6, 1),
+ SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
+ SCM_PACK_OP_12_12 (mov, 0, 2),
+ SCM_PACK_OP_24 (tail_call_shuffle, 7)
};
static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
- SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
+ SCM_PACK_OP_24 (assert_nargs_ee, 2),
+ SCM_PACK_OP_24 (call_cc, 0)
};
* VM
*/
-static SCM
-resolve_variable (SCM what, SCM module)
-{
- if (SCM_LIKELY (scm_is_symbol (what)))
- {
- if (scm_is_true (module))
- return scm_module_lookup (module, what);
- else
- return scm_module_lookup (scm_the_root_module (), what);
- }
- else
- {
- SCM modname, sym, public;
-
- modname = SCM_CAR (what);
- sym = SCM_CADR (what);
- public = SCM_CADDR (what);
-
- if (!scm_module_system_booted_p)
- {
-#ifdef VM_ENABLE_PARANOID_ASSERTIONS
- ASSERT (scm_is_false (public));
- ASSERT (scm_is_true
- (scm_equal_p (modname,
- scm_list_1 (scm_from_utf8_symbol ("guile")))));
-#endif
- return scm_lookup (sym);
- }
- else if (scm_is_true (public))
- return scm_public_lookup (modname, sym);
- else
- return scm_private_lookup (modname, sym);
- }
-}
-
#define VM_MIN_STACK_SIZE (1024)
#define VM_DEFAULT_STACK_SIZE (256 * 1024)
static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
vm_stack_size = size;
}
-#define RTL_VM_NAME rtl_vm_regular_engine
+#define VM_NAME vm_regular_engine
+#define VM_USE_HOOKS 0
#define FUNC_NAME "vm-regular-engine"
-#define VM_ENGINE SCM_VM_REGULAR_ENGINE
#include "vm-engine.c"
-#undef RTL_VM_NAME
#undef FUNC_NAME
-#undef VM_ENGINE
+#undef VM_USE_HOOKS
+#undef VM_NAME
-#define RTL_VM_NAME rtl_vm_debug_engine
+#define VM_NAME vm_debug_engine
+#define VM_USE_HOOKS 1
#define FUNC_NAME "vm-debug-engine"
-#define VM_ENGINE SCM_VM_DEBUG_ENGINE
#include "vm-engine.c"
-#undef RTL_VM_NAME
#undef FUNC_NAME
-#undef VM_ENGINE
+#undef VM_USE_HOOKS
+#undef VM_NAME
-typedef SCM (*scm_t_rtl_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs);
+typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp,
+ SCM program, SCM *argv, size_t nargs);
-static const scm_t_rtl_vm_engine rtl_vm_engines[] =
- { rtl_vm_regular_engine, rtl_vm_debug_engine };
+static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
+ { vm_regular_engine, vm_debug_engine };
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
"stack-base");
#endif
-#ifdef VM_ENABLE_STACK_NULLING
- memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
-#endif
vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
SCM
-scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
+ struct scm_vm *vp = scm_the_vm ();
SCM_CHECK_STACK;
- return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
+ return vm_engines[vp->engine](vp, proc, argv, nargs);
}
-/* Scheme interface */
-
-SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
- (void),
- "Return the current thread's VM.")
-#define FUNC_NAME s_scm_the_vm
+struct scm_vm *
+scm_the_vm (void)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
if (SCM_UNLIKELY (scm_is_false (t->vm)))
t->vm = make_vm ();
- return t->vm;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_vm_p
-{
- return scm_from_bool (SCM_VM_P (obj));
+ return SCM_VM_DATA (t->vm);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
- (void),
- "")
-#define FUNC_NAME s_scm_make_vm,
-{
- return make_vm ();
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_ip
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_sp
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fp
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
-}
-#undef FUNC_NAME
+/* Scheme interface */
#define VM_DEFINE_HOOK(n) \
{ \
struct scm_vm *vp; \
- SCM_VALIDATE_VM (1, vm); \
- vp = SCM_VM_DATA (vm); \
+ vp = scm_the_vm (); \
if (scm_is_false (vp->hooks[n])) \
vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
return vp->hooks[n]; \
}
-SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_apply_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_push_continuation_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_pop_continuation_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_next_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_abort_continuation_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_restore_continuation_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_trace_level
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_int (SCM_VM_DATA (vm)->trace_level);
+ return scm_from_int (scm_the_vm ()->trace_level);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
- (SCM vm, SCM level),
+SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0,
+ (SCM level),
"")
#define FUNC_NAME s_scm_set_vm_trace_level_x
{
- SCM_VALIDATE_VM (1, vm);
- SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
+ scm_the_vm ()->trace_level = scm_to_int (level);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
}
-SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_engine
{
- SCM_VALIDATE_VM (1, vm);
- return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
+ return vm_engine_to_symbol (scm_the_vm ()->engine, FUNC_NAME);
}
#undef FUNC_NAME
void
-scm_c_set_vm_engine_x (SCM vm, int engine)
+scm_c_set_vm_engine_x (int engine)
#define FUNC_NAME "set-vm-engine!"
{
- SCM_VALIDATE_VM (1, vm);
-
if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
SCM_MISC_ERROR ("Unknown VM engine: ~a",
scm_list_1 (scm_from_int (engine)));
- SCM_VM_DATA (vm)->engine = engine;
+ scm_the_vm ()->engine = engine;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
- (SCM vm, SCM engine),
+SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0,
+ (SCM engine),
"")
#define FUNC_NAME s_scm_set_vm_engine_x
{
- scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
+ scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-static void reinstate_vm (SCM vm)
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- t->vm = vm;
-}
-
-SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
- (SCM vm, SCM proc, SCM args),
+/* FIXME: This function makes no sense, but we keep it to make sure we
+ have a way of switching to the debug or regular VM. */
+SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1,
+ (SCM proc, SCM args),
"Apply @var{proc} to @var{args} in a dynamic extent in which\n"
- "@var{vm} is the current VM.\n\n"
- "As an implementation restriction, if @var{vm} is not the same\n"
- "as the current thread's VM, continuations captured within the\n"
- "call to @var{proc} may not be reinstated once control leaves\n"
- "@var{proc}.")
+ "@var{vm} is the current VM.")
#define FUNC_NAME s_scm_call_with_vm
{
- SCM prev_vm, ret;
- SCM *argv;
- int i, nargs;
- scm_t_wind_flags flags;
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROC (2, proc);
-
- nargs = scm_ilength (args);
- if (SCM_UNLIKELY (nargs < 0))
- scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
-
- argv = alloca (nargs * sizeof(SCM));
- for (i = 0; i < nargs; i++)
- {
- argv[i] = SCM_CAR (args);
- args = SCM_CDR (args);
- }
-
- prev_vm = t->vm;
-
- /* Reentry can happen via invokation of a saved continuation, but
- continuations only save the state of the VM that they are in at
- capture-time, which might be different from this one. So, in the
- case that the VMs are different, set up a non-rewindable frame to
- prevent reinstating an incomplete continuation. */
- flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
- if (flags)
- {
- scm_dynwind_begin (0);
- scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
- t->vm = vm;
- }
-
- ret = scm_c_vm_run (vm, proc, argv, nargs);
-
- if (flags)
- scm_dynwind_end ();
-
- return ret;
+ return scm_apply_0 (proc, args);
}
#undef FUNC_NAME
* Initialize
*/
-SCM scm_load_compiled_with_vm (SCM file)
+SCM
+scm_load_compiled_with_vm (SCM file)
{
- SCM program = scm_load_thunk_from_file (file);
-
- return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
+ return scm_call_0 (scm_load_thunk_from_file (file));
}
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
- rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code);
- SCM_SET_CELL_WORD_0 (rtl_boot_continuation,
- (SCM_CELL_WORD_0 (rtl_boot_continuation)
+ vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code);
+ SCM_SET_CELL_WORD_0 (vm_boot_continuation,
+ (SCM_CELL_WORD_0 (vm_boot_continuation)
| SCM_F_PROGRAM_IS_BOOT));
#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
- vm_builtin_##builtin = scm_i_make_rtl_program (vm_builtin_##builtin##_code);
+ vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
#undef DEFINE_BUILTIN
HCoop / bpt / guile.git / blobdiff