#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"
#include "private-gc.h" /* scm_getenv_int */
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_t_uint8 *mvra, scm_t_dynstack *dynstack,
- scm_t_uint32 flags)
+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->mvra = mvra;
p->sp = sp;
p->fp = fp;
memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
vp = SCM_VM_DATA (vm);
cp = SCM_VM_CONT_DATA (cont);
- if (n == 0 && !cp->mvra)
- scm_misc_error (NULL, "Too few values returned to continuation",
- SCM_EOL);
-
- if (vp->stack_size < cp->stack_size + n + 1)
+ 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));
-#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));
- if (n == 1 || !cp->mvra)
- {
- vp->ip = cp->ra;
- vp->sp++;
- *vp->sp = argv_copy[0];
- }
- else
- {
- size_t i;
- for (i = 0; i < n; i++)
- {
- vp->sp++;
- *vp->sp = argv_copy[i];
- }
- vp->sp++;
- *vp->sp = scm_from_size_t (n);
- vp->ip = cp->mvra;
- }
+ {
+ size_t i;
+
+ /* Push on an empty frame, as the continuation expects. */
+ for (i = 0; i < 3; i++)
+ {
+ vp->sp++;
+ *vp->sp = SCM_BOOL_F;
+ }
+
+ /* Push the return values. */
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ vp->ip = cp->ra;
+ }
}
SCM
vm = scm_the_vm ();
vp = SCM_VM_DATA (vm);
- return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL,
+ 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 (SCM vm) SCM_NOINLINE;
+static void vm_dispatch_push_continuation_hook (SCM vm) SCM_NOINLINE;
+static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp) SCM_NOINLINE;
+static void vm_dispatch_next_hook (SCM vm) SCM_NOINLINE;
+static void vm_dispatch_abort_hook (SCM vm) SCM_NOINLINE;
+static void vm_dispatch_restore_continuation_hook (SCM vm) SCM_NOINLINE;
static void
vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
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.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);
vp->trace_level = saved_trace_level;
}
+static void
+vm_dispatch_apply_hook (SCM vm)
+{
+ return vm_dispatch_hook (vm, SCM_VM_APPLY_HOOK, NULL, 0);
+}
+static void vm_dispatch_push_continuation_hook (SCM vm)
+{
+ return vm_dispatch_hook (vm, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
+}
+static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp)
+{
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ return vm_dispatch_hook (vm, 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 (SCM vm)
+{
+ return vm_dispatch_hook (vm, SCM_VM_NEXT_HOOK, NULL, 0);
+}
+static void vm_dispatch_abort_hook (SCM vm)
+{
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ return vm_dispatch_hook (vm, 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 (SCM vm)
+{
+ return vm_dispatch_hook (vm, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0);
+}
+
static void
vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
scm_i_jmp_buf *current_registers) SCM_NORETURN;
vp = SCM_VM_DATA (vm);
cp = SCM_VM_CONT_DATA (cont);
- base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
+ base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
reloc = cp->reloc + (base - cp->stack_base);
#define RELOC(scm_p) \
vp->sp = base - 1 + cp->stack_size;
vp->fp = RELOC (cp->fp);
- vp->ip = cp->mvra;
+ vp->ip = cp->ra;
- /* now push args. ip is in a MV context. */
+ /* Push the arguments. */
for (i = 0; i < n; i++)
{
vp->sp++;
*vp->sp = argv_copy[i];
}
- vp->sp++;
- *vp->sp = scm_from_size_t (n);
/* The prompt captured a slice of the dynamic stack. Here we wind
those entries onto the current thread's stack. We also have to
\f
-static SCM 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 vm_boot_continuation_code[] = {
+ SCM_PACK_OP_24 (halt, 0)
+};
-static SCM rtl_boot_continuation;
-static SCM rtl_apply;
-static SCM rtl_values;
+static const scm_t_uint32 vm_builtin_apply_code[] = {
+ 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 rtl_boot_continuation_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
+static const scm_t_uint32 vm_builtin_values_code[] = {
+ SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
};
-static const scm_t_uint32 rtl_apply_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0) /* proc in r1, args from r2, nargs set */
+static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
+ 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_OP_24 (return_values, 0) /* vals from r1 */
};
-static const scm_t_uint32 rtl_values_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
+ 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_OP_24 (assert_nargs_ee, 2),
+ SCM_PACK_OP_24 (call_cc, 0)
+};
-\f
-/*
- * VM
- */
static SCM
-resolve_variable (SCM what, SCM module)
+scm_vm_builtin_ref (unsigned idx)
{
- if (SCM_LIKELY (scm_is_symbol (what)))
+ switch (idx)
{
- if (scm_is_true (module))
- return scm_module_lookup (module, what);
- else
- return scm_module_lookup (scm_the_root_module (), what);
+#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
+ case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: abort();
}
- else
- {
- SCM modname, sym, public;
+}
+
+SCM scm_sym_apply;
+static SCM scm_sym_values;
+static SCM scm_sym_abort_to_prompt;
+static SCM scm_sym_call_with_values;
+static SCM scm_sym_call_with_current_continuation;
+
+SCM
+scm_vm_builtin_name_to_index (SCM name)
+#define FUNC_NAME "builtin-name->index"
+{
+ SCM_VALIDATE_SYMBOL (1, name);
+
+#define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
+ if (scm_is_eq (name, scm_sym_##builtin)) \
+ return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
+ FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
+#undef NAME_TO_INDEX
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
+{
+ unsigned idx;
- modname = SCM_CAR (what);
- sym = SCM_CADR (what);
- public = SCM_CADDR (what);
+ SCM_VALIDATE_UINT_COPY (1, index, idx);
- if (scm_is_true (public))
- return scm_public_lookup (modname, sym);
- else
- return scm_private_lookup (modname, sym);
+ switch (idx)
+ {
+#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
+ case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: return SCM_BOOL_F;
}
}
-
+#undef FUNC_NAME
+
+static void
+scm_init_vm_builtins (void)
+{
+ scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
+ scm_vm_builtin_name_to_index);
+ scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
+ scm_vm_builtin_index_to_name);
+}
+
+SCM
+scm_i_call_with_current_continuation (SCM proc)
+{
+ return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
+}
+
+\f
+/*
+ * VM
+ */
+
#define VM_MIN_STACK_SIZE (1024)
-#define VM_DEFAULT_STACK_SIZE (64 * 1024)
+#define VM_DEFAULT_STACK_SIZE (256 * 1024)
static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
static void
vm_stack_size = size;
}
-#define VM_NAME vm_regular_engine
-#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 VM_NAME
-#undef RTL_VM_NAME
#undef FUNC_NAME
-#undef VM_ENGINE
+#undef VM_USE_HOOKS
+#undef VM_NAME
-#define VM_NAME vm_debug_engine
-#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 VM_NAME
-#undef RTL_VM_NAME
#undef FUNC_NAME
-#undef VM_ENGINE
-
-static const scm_t_vm_engine vm_engines[] =
- { vm_regular_engine, vm_debug_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) (SCM vm, 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;
{
struct scm_vm *vp = SCM_VM_DATA (vm);
SCM_CHECK_STACK;
- if (SCM_RTL_PROGRAM_P (program))
- return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
- else
- return vm_engines[vp->engine](vm, program, argv, nargs);
+ return vm_engines[vp->engine](vm, program, argv, nargs);
}
/* Scheme interface */
}
-static SCM
-make_boot_program (void)
+void
+scm_init_vm_builtin_properties (void)
{
- struct scm_objcode *bp;
- size_t bp_size;
- SCM u8vec, ret;
-
- const scm_t_uint8 text[] = {
- scm_op_make_int8_1,
- scm_op_halt
- };
-
- bp_size = sizeof (struct scm_objcode) + sizeof (text);
- bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
- memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
- bp->len = sizeof(text);
- bp->metalen = 0;
-
- u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size, SCM_BOOL_F);
- ret = scm_make_program (scm_bytecode_to_objcode (u8vec, SCM_UNDEFINED),
- SCM_BOOL_F, SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
-
- return ret;
+ /* FIXME: Seems hacky to do this here, but oh well :/ */
+ scm_sym_apply = scm_from_utf8_symbol ("apply");
+ scm_sym_values = scm_from_utf8_symbol ("values");
+ scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
+ scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
+ scm_sym_call_with_current_continuation =
+ scm_from_utf8_symbol ("call-with-current-continuation");
+
+#define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
+ scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
+ scm_sym_##builtin); \
+ scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
+ SCM_I_MAKINUM (req), \
+ SCM_I_MAKINUM (opt), \
+ scm_from_bool (rest));
+ FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
+#undef INIT_BUILTIN
}
void
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_vm_builtins",
+ (scm_t_extension_init_func)scm_init_vm_builtins,
+ NULL);
initialize_default_stack_size ();
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
- boot_continuation = make_boot_program ();
-
- 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));
- rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
- rtl_values = scm_i_make_rtl_program (rtl_values_code);
+
+#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
+ vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
+ FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
+#undef DEFINE_BUILTIN
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
HCoop / bpt / guile.git / blobdiff