-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* 02110-1301 USA
*/
+/* For mremap(2) on GNU/Linux systems. */
+#define _GNU_SOURCE
+
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <alignof.h>
#include <string.h>
#include <stdint.h>
+#include <unistd.h>
+
+#ifdef HAVE_SYS_MMAN_H
+#include <sys/mman.h>
+#endif
#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
#include "_scm.h"
#include "control.h"
#include "frames.h"
+#include "gc-inline.h"
#include "instructions.h"
-#include "objcodes.h"
+#include "loader.h"
#include "programs.h"
+#include "simpos.h"
#include "vm.h"
-
-#include "private-gc.h" /* scm_getenv_int */
+#include "vm-builtins.h"
static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
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
+static void vm_expand_stack (struct scm_vm *vp) SCM_NOINLINE;
-/* 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
- for a discussion. */
-#define VM_ENABLE_PRECISE_STACK_GC_SCAN
+/* RESTORE is for the case where we know we have done a PUSH of equal or
+ greater stack size in the past. Otherwise PUSH is the thing, which
+ may expand the stack. */
+enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE };
-/* Size in SCM objects of the stack reserve. The reserve is used to run
- exception handling code in case of a VM stack overflow. */
-#define VM_STACK_RESERVE_SIZE 512
+static inline void
+vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind)
+{
+ vp->sp = new_sp;
+ if (new_sp > vp->sp_max_since_gc)
+ {
+ vp->sp_max_since_gc = new_sp;
+ if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit)
+ vm_expand_stack (vp);
+ }
+}
+static inline void
+vm_push_sp (struct scm_vm *vp, SCM *new_sp)
+{
+ vm_increase_sp (vp, new_sp, VM_SP_PUSH);
+}
+
+static inline void
+vm_restore_sp (struct scm_vm *vp, SCM *new_sp)
+{
+ vm_increase_sp (vp, new_sp, VM_SP_RESTORE);
+}
\f
/*
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));
}
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;
+ 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);
- 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)
- scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
- scm_list_2 (vm, cont));
+ /* FIXME: Need to prevent GC while futzing with the stack; otherwise,
+ another thread causing GC may initiate a mark of a stack in an
+ inconsistent state. */
-#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;
+ /* We know that there is enough space for the continuation, because we
+ captured it in the past. However there may have been an expansion
+ since the capture, so we may have to re-link the frame
+ pointers. */
+ reloc = (vp->stack_base - (cp->stack_base - cp->reloc));
+ vp->fp = cp->fp + reloc;
memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
+ vm_restore_sp (vp, cp->sp + reloc);
- if (n == 1 || !cp->mvra)
+ if (reloc)
{
- vp->ip = cp->ra;
- vp->sp++;
- *vp->sp = argv_copy[0];
- }
- else
- {
- size_t i;
- for (i = 0; i < n; i++)
+ SCM *fp = vp->fp;
+ while (fp)
{
- vp->sp++;
- *vp->sp = argv_copy[i];
+ SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ if (next_fp)
+ {
+ next_fp += reloc;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp);
+ }
+ fp = next_fp;
}
- vp->sp++;
- *vp->sp = scm_from_size_t (n);
- vp->ip = cp->mvra;
}
+
+ /* Now we have the continuation properly copied over. We just need to
+ copy the arguments. It is not guaranteed that there is actually
+ space for the arguments, though, so we have to bump the SP first. */
+ vm_push_sp (vp, vp->sp + 3 + n);
+
+ /* Now copy on an empty frame and the return values, as the
+ continuation expects. */
+ {
+ SCM *base = vp->sp + 1 - 3 - n;
+ size_t i;
+
+ for (i = 0; i < 3; i++)
+ base[i] = SCM_BOOL_F;
+
+ for (i = 0; i < n; i++)
+ base[i + 3] = argv_copy[i];
+ }
+
+ vp->ip = cp->ra;
}
+static struct scm_vm * thread_vm (scm_i_thread *t);
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 = thread_vm (thread);
- 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 (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_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, size_t n, scm_i_jmp_buf *current_registers) SCM_NORETURN;
+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_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, size_t n, scm_i_jmp_buf *current_registers)
+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;
ssize_t tail_len;
- SCM tag, tail, *argv;
+ SCM *argv;
- /* FIXME: VM_ENABLE_STACK_NULLING */
- tail = *(SCM_VM_DATA (vm)->sp--);
- /* NULLSTACK (1) */
tail_len = scm_ilength (tail);
if (tail_len < 0)
scm_misc_error ("vm-engine", "tail values to abort should be a list",
scm_list_1 (tail));
- tag = SCM_VM_DATA (vm)->sp[-n];
- argv = alloca ((n + tail_len) * sizeof (SCM));
- for (i = 0; i < n; i++)
- argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
- for (; i < n + tail_len; i++, tail = scm_cdr (tail))
+ argv = alloca ((nstack + tail_len) * sizeof (SCM));
+ for (i = 0; i < nstack; i++)
+ argv[i] = stack_args[i];
+ for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
argv[i] = scm_car (tail);
- /* NULLSTACK (n + 1) */
- SCM_VM_DATA (vm)->sp -= n + 1;
- scm_c_abort (vm, tag, n + tail_len, argv, current_registers);
+ /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
+ vp->sp = sp;
+
+ 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_UPPER_ADDRESS (vp->fp) + 1;
- reloc = cp->reloc + (base - cp->stack_base);
-#define RELOC(scm_p) \
- (((SCM *) (scm_p)) + reloc)
+ vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1);
- 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));
+ base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
+ reloc = cp->reloc + (base - cp->stack_base);
memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
+ vp->fp = cp->fp + reloc;
+ vp->ip = cp->ra;
+
/* now relocate frame pointers */
{
SCM *fp;
- for (fp = RELOC (cp->fp);
+ for (fp = vp->fp;
SCM_FRAME_LOWER_ADDRESS (fp) > base;
fp = SCM_FRAME_DYNAMIC_LINK (fp))
- SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc);
}
- vp->sp = base - 1 + cp->stack_size;
- vp->fp = RELOC (cp->fp);
- vp->ip = cp->mvra;
-
- /* 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);
+ vp->sp[i + 1 - n] = argv_copy[i];
/* The prompt captured a slice of the dynamic stack. Here we wind
those entries onto the current thread's stack. We also have to
scm_dynstack_wind_1 (dynstack, walk);
}
}
-#undef RELOC
-}
-
-\f
-/*
- * VM Internal functions
- */
-
-void
-scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
-{
- const struct scm_vm *vm;
-
- vm = SCM_VM_DATA (x);
-
- scm_puts_unlocked ("#<vm ", port);
- switch (vm->engine)
- {
- case SCM_VM_REGULAR_ENGINE:
- scm_puts_unlocked ("regular-engine ", port);
- break;
-
- case SCM_VM_DEBUG_ENGINE:
- scm_puts_unlocked ("debug-engine ", port);
- break;
-
- default:
- scm_puts_unlocked ("unknown-engine ", port);
- }
- scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts_unlocked (">", port);
}
\f
static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN SCM_NOINLINE;
static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_out_of_range (const char *subr, SCM k) SCM_NORETURN SCM_NOINLINE;
static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE;
scm_list_1 (proc), scm_list_1 (proc));
}
-static void
-vm_error_stack_overflow (struct scm_vm *vp)
-{
- if (vp->stack_limit < vp->stack_base + vp->stack_size)
- /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
- that `throw' below can run on this VM. */
- vp->stack_limit = vp->stack_base + vp->stack_size;
- else
- /* There is no space left on the stack. FIXME: Do something more
- sensible here! */
- abort ();
- vm_error ("VM: Stack overflow", SCM_UNDEFINED);
-}
-
static void
vm_error_stack_underflow (void)
{
scm_wrong_type_arg_msg (subr, 1, x, "struct");
}
+static void
+vm_error_not_a_vector (const char *subr, SCM x)
+{
+ scm_wrong_type_arg_msg (subr, 1, x, "vector");
+}
+
+static void
+vm_error_out_of_range (const char *subr, SCM k)
+{
+ scm_to_size_t (k);
+ scm_out_of_range (subr, k);
+}
+
static void
vm_error_no_values (void)
{
\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 SCM rtl_boot_continuation;
-static SCM rtl_apply;
-static SCM rtl_values;
+static const scm_t_uint32 vm_boot_continuation_code[] = {
+ SCM_PACK_OP_24 (halt, 0)
+};
-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_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_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_values_code[] = {
+ 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_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 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);
- modname = SCM_CAR (what);
- sym = SCM_CADR (what);
- public = SCM_CADDR (what);
+#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
- if (scm_is_true (public))
- return scm_public_lookup (modname, sym);
- else
- return scm_private_lookup (modname, sym);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
+{
+ unsigned idx;
+
+ SCM_VALIDATE_UINT_COPY (1, index, idx);
+
+ 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;
}
}
-
-#define VM_MIN_STACK_SIZE (1024)
-#define VM_DEFAULT_STACK_SIZE (64 * 1024)
-static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
+#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
+ */
+
+/* The page size. */
+static size_t page_size;
+
+/* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
+ 64-bit machines. */
+static const size_t hard_max_stack_size = 512 * 1024 * 1024;
+
+/* Initial stack size. Defaults to one page. */
+static size_t initial_stack_size;
+
+/* Default soft stack limit is 1M words (4 or 8 megabytes). */
+static size_t default_max_stack_size = 1024 * 1024;
static void
initialize_default_stack_size (void)
{
- int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
- if (size >= VM_MIN_STACK_SIZE)
- vm_stack_size = size;
+ initial_stack_size = page_size / sizeof (SCM);
+
+ {
+ int size;
+ size = scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size);
+ if (size >= initial_stack_size
+ && (size_t) size < ((size_t) -1) / sizeof(SCM))
+ default_max_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
+#undef VM_USE_HOOKS
+#undef VM_NAME
+
+typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp,
+ scm_i_jmp_buf *registers, int resume);
-static const scm_t_vm_engine vm_engines[] =
+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
+static SCM*
+allocate_stack (size_t size)
+#define FUNC_NAME "make_vm"
+{
+ void *ret;
+
+ if (size >= ((size_t) -1) / sizeof (SCM))
+ abort ();
-/* The GC "kind" for the VM stack. */
-static int vm_stack_gc_kind;
+ size *= sizeof (SCM);
+#if HAVE_SYS_MMAN_H
+ ret = mmap (NULL, size, PROT_READ | PROT_WRITE,
+ MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
+ if (ret == MAP_FAILED)
+ ret = NULL;
+#else
+ ret = malloc (size);
#endif
-static SCM
-make_vm (void)
-#define FUNC_NAME "make_vm"
+ if (!ret)
+ {
+ perror ("allocate_stack failed");
+ return NULL;
+ }
+
+ return (SCM *) ret;
+}
+#undef FUNC_NAME
+
+static void
+free_stack (SCM *stack, size_t size)
{
- int i;
- struct scm_vm *vp;
+ size *= sizeof (SCM);
- vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+#if HAVE_SYS_MMAN_H
+ munmap (stack, size);
+#else
+ free (stack);
+#endif
+}
- vp->stack_size= vm_stack_size;
+static SCM*
+expand_stack (SCM *old_stack, size_t old_size, size_t new_size)
+#define FUNC_NAME "expand_stack"
+{
+#if defined MREMAP_MAYMOVE
+ void *new_stack;
+
+ if (new_size >= ((size_t) -1) / sizeof (SCM))
+ abort ();
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
- vp->stack_base = (SCM *)
- GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
+ old_size *= sizeof (SCM);
+ new_size *= sizeof (SCM);
- /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
- top is. */
- *vp->stack_base = SCM_PACK_POINTER (vp);
- vp->stack_base++;
- vp->stack_size--;
+ new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE);
+ if (new_stack == MAP_FAILED)
+ return NULL;
+
+ return (SCM *) new_stack;
#else
- vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
- "stack-base");
-#endif
+ SCM *new_stack;
-#ifdef VM_ENABLE_STACK_NULLING
- memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
+ new_stack = allocate_stack (new_size);
+ if (!new_stack)
+ return NULL;
+
+ memcpy (new_stack, old_stack, old_size * sizeof (SCM));
+ free_stack (old_stack, old_size);
+
+ return new_stack;
#endif
- vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
+}
+#undef FUNC_NAME
+
+static struct scm_vm *
+make_vm (void)
+#define FUNC_NAME "make_vm"
+{
+ int i;
+ struct scm_vm *vp;
+
+ vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+
+ vp->stack_size = initial_stack_size;
+ vp->stack_base = allocate_stack (vp->stack_size);
+ if (!vp->stack_base)
+ /* As in expand_stack, we don't have any way to throw an exception
+ if we can't allocate one measely page -- there's no stack to
+ handle it. For now, abort. */
+ abort ();
+ vp->stack_limit = vp->stack_base + vp->stack_size;
+ vp->max_stack_size = default_max_stack_size;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
- return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
+
+ return vp;
}
#undef FUNC_NAME
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
-
-/* Mark the VM stack region between its base and its current top. */
-static struct GC_ms_entry *
-vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
- struct GC_ms_entry *mark_stack_limit, GC_word env)
+static void
+return_unused_stack_to_os (struct scm_vm *vp)
{
- GC_word *word;
- const struct scm_vm *vm;
-
- /* The first word of the VM stack should contain a pointer to the
- corresponding VM. */
- vm = * ((struct scm_vm **) addr);
+#if HAVE_SYS_MMAN_H
+ scm_t_uintptr start = (scm_t_uintptr) (vp->sp + 1);
+ scm_t_uintptr end = (scm_t_uintptr) vp->stack_limit;
+ /* The second condition is needed to protect against wrap-around. */
+ if (vp->sp_max_since_gc < vp->stack_limit && vp->sp < vp->sp_max_since_gc)
+ end = (scm_t_uintptr) (vp->sp_max_since_gc + 1);
+
+ start = ((start - 1U) | (page_size - 1U)) + 1U; /* round up */
+ end = ((end - 1U) | (page_size - 1U)) + 1U; /* round up */
+
+ /* Return these pages to the OS. The next time they are paged in,
+ they will be zeroed. */
+ if (start < end)
+ {
+ int ret = 0;
- if (vm == NULL
- || (SCM *) addr != vm->stack_base - 1)
- /* ADDR must be a pointer to a free-list element, which we must ignore
- (see warning in <gc/gc_mark.h>). */
- return mark_stack_ptr;
+ do
+ ret = madvise ((void *) start, end - start, MADV_DONTNEED);
+ while (ret && errno == -EAGAIN);
- for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
- mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
- mark_stack_ptr, mark_stack_limit,
- NULL);
+ if (ret)
+ perror ("madvise failed");
+ }
- return mark_stack_ptr;
+ vp->sp_max_since_gc = vp->sp;
+#endif
}
-#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
+#define DEAD_SLOT_MAP_CACHE_SIZE 32U
+struct dead_slot_map_cache_entry
+{
+ scm_t_uint32 *ip;
+ const scm_t_uint8 *map;
+};
+struct dead_slot_map_cache
+{
+ struct dead_slot_map_cache_entry entries[DEAD_SLOT_MAP_CACHE_SIZE];
+};
-SCM
-scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
+static const scm_t_uint8 *
+find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- SCM_CHECK_STACK;
- return vm_engines[vp->engine](vm, program, argv, nargs);
-}
+ /* The lower two bits should be zero. FIXME: Use a better hash
+ function; we don't expose scm_raw_hashq currently. */
+ size_t slot = (((scm_t_uintptr) ip) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE;
+ const scm_t_uint8 *map;
-/* Scheme interface */
+ if (cache->entries[slot].ip == ip)
+ map = cache->entries[slot].map;
+ else
+ {
+ map = scm_find_dead_slot_map_unlocked (ip);
+ cache->entries[slot].ip = ip;
+ cache->entries[slot].map = map;
+ }
-SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
- (void),
- "Return the current thread's VM.")
-#define FUNC_NAME s_scm_the_vm
+ return map;
+}
+
+/* Mark the VM stack region between its base and its current top. */
+struct GC_ms_entry *
+scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit)
{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ SCM *sp, *fp;
+ /* The first frame will be marked conservatively (without a dead
+ slot map). This is because GC can happen at any point within the
+ hottest activation, due to multiple threads or per-instruction
+ hooks, and providing dead slot maps for all points in a program
+ would take a prohibitive amount of space. */
+ const scm_t_uint8 *dead_slots = NULL;
+ scm_t_uintptr upper = (scm_t_uintptr) GC_greatest_plausible_heap_addr;
+ scm_t_uintptr lower = (scm_t_uintptr) GC_least_plausible_heap_addr;
+ struct dead_slot_map_cache cache;
+
+ memset (&cache, 0, sizeof (cache));
+
+ for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp))
+ {
+ for (; sp >= &SCM_FRAME_LOCAL (fp, 0); sp--)
+ {
+ SCM elt = *sp;
+ if (SCM_NIMP (elt)
+ && SCM_UNPACK (elt) >= lower && SCM_UNPACK (elt) <= upper)
+ {
+ if (dead_slots)
+ {
+ size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0);
+ if (dead_slots[slot / 8U] & (1U << (slot % 8U)))
+ {
+ /* This value may become dead as a result of GC,
+ so we can't just leave it on the stack. */
+ *sp = SCM_UNBOUND;
+ continue;
+ }
+ }
+
+ mark_stack_ptr = GC_mark_and_push ((void *) elt,
+ mark_stack_ptr,
+ mark_stack_limit,
+ NULL);
+ }
+ }
+ sp = SCM_FRAME_PREVIOUS_SP (fp);
+ /* Inner frames may have a dead slots map for precise marking.
+ Note that there may be other reasons to not have a dead slots
+ map, e.g. if all of the frame's slots below the callee frame
+ are live. */
+ dead_slots = find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache);
+ }
- if (SCM_UNLIKELY (scm_is_false (t->vm)))
- t->vm = make_vm ();
+ return_unused_stack_to_os (vp);
- return t->vm;
+ return mark_stack_ptr;
}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_vm_p
+/* Free the VM stack, as this thread is exiting. */
+void
+scm_i_vm_free_stack (struct scm_vm *vp)
{
- return scm_from_bool (SCM_VM_P (obj));
+ free_stack (vp->stack_base, vp->stack_size);
+ vp->stack_base = vp->stack_limit = NULL;
+ vp->stack_size = 0;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
- (void),
- "")
-#define FUNC_NAME s_scm_make_vm,
+static void
+vm_expand_stack (struct scm_vm *vp)
{
- return make_vm ();
+ scm_t_ptrdiff stack_size = vp->sp + 1 - vp->stack_base;
+
+ if (stack_size > hard_max_stack_size)
+ {
+ /* We have expanded the soft limit to the point that we reached a
+ hard limit. There is nothing sensible to do. */
+ fprintf (stderr, "Hard stack size limit (%zu words) reached; aborting.\n",
+ hard_max_stack_size);
+ abort ();
+ }
+
+ /* FIXME: Prevent GC while we expand the stack, to ensure that a
+ stack marker can trace the stack. */
+ if (stack_size > vp->stack_size)
+ {
+ SCM *old_stack, *new_stack;
+ size_t new_size;
+ scm_t_ptrdiff reloc;
+
+ new_size = vp->stack_size;
+ while (new_size < stack_size)
+ new_size *= 2;
+ old_stack = vp->stack_base;
+ new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size);
+ if (!new_stack)
+ /* It would be nice to throw an exception here, but that is
+ extraordinarily hard. Exceptionally hard, you might say!
+ "throw" is implemented in Scheme, and there may be arbitrary
+ pre-unwind handlers that push on more frames. We will
+ endeavor to do so in the future, but for now we just
+ abort. */
+ abort ();
+
+ vp->stack_base = new_stack;
+ vp->stack_size = new_size;
+ vp->stack_limit = vp->stack_base + new_size;
+ reloc = vp->stack_base - old_stack;
+
+ if (reloc)
+ {
+ SCM *fp;
+ if (vp->fp)
+ vp->fp += reloc;
+ vp->sp += reloc;
+ vp->sp_max_since_gc += reloc;
+ fp = vp->fp;
+ while (fp)
+ {
+ SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ if (next_fp)
+ {
+ next_fp += reloc;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp);
+ }
+ fp = next_fp;
+ }
+ }
+ }
+
+ if (stack_size >= vp->max_stack_size)
+ {
+ /* Expand the soft limit by 256K entries to give us space to
+ handle the error. */
+ vp->max_stack_size += 256 * 1024;
+
+ /* If it's still not big enough... it's quite improbable, but go
+ ahead and set to the full available stack size. */
+ if (vp->max_stack_size < stack_size)
+ vp->max_stack_size = vp->stack_size;
+
+ /* But don't exceed the hard maximum. */
+ if (vp->max_stack_size > hard_max_stack_size)
+ vp->max_stack_size = hard_max_stack_size;
+
+ /* Finally, reset the limit, to catch further overflows. */
+ vp->stack_limit = vp->stack_base + vp->max_stack_size;
+
+ vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+ }
+
+ /* Otherwise continue, with the new enlarged stack. */
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_ip
+static struct scm_vm *
+thread_vm (scm_i_thread *t)
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
+ if (SCM_UNLIKELY (!t->vp))
+ t->vp = make_vm ();
+
+ return t->vp;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_sp
+struct scm_vm *
+scm_the_vm (void)
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
+ return thread_vm (SCM_I_CURRENT_THREAD);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fp
+SCM
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
+ scm_i_thread *thread;
+ struct scm_vm *vp;
+ SCM *base;
+ ptrdiff_t base_frame_size;
+ /* Cached variables. */
+ scm_i_jmp_buf registers; /* used for prompts */
+ size_t i;
+
+ thread = SCM_I_CURRENT_THREAD;
+ vp = thread_vm (thread);
+
+ SCM_CHECK_STACK;
+
+ /* Check that we have enough space: 3 words for the boot continuation,
+ and 3 + nargs for the procedure application. */
+ base_frame_size = 3 + 3 + nargs;
+ vm_push_sp (vp, vp->sp + base_frame_size);
+ base = vp->sp + 1 - base_frame_size;
+
+ /* Since it's possible to receive the arguments on the stack itself,
+ shuffle up the arguments first. */
+ for (i = nargs; i > 0; i--)
+ base[6 + i - 1] = argv[i - 1];
+
+ /* Push the boot continuation, which calls PROC and returns its
+ result(s). */
+ base[0] = SCM_PACK (vp->fp); /* dynamic link */
+ base[1] = SCM_PACK (vp->ip); /* ra */
+ base[2] = vm_boot_continuation;
+ vp->fp = &base[2];
+ vp->ip = (scm_t_uint32 *) vm_boot_continuation_code;
+
+ /* The pending call to PROC. */
+ base[3] = SCM_PACK (vp->fp); /* dynamic link */
+ base[4] = SCM_PACK (vp->ip); /* ra */
+ base[5] = proc;
+ vp->fp = &base[5];
+
+ {
+ int resume = SCM_I_SETJMP (registers);
+
+ if (SCM_UNLIKELY (resume))
+ /* Non-local return. */
+ vm_dispatch_abort_hook (vp);
+
+ return vm_engines[vp->engine](thread, vp, ®isters, resume);
+ }
}
-#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),
- "")
-#define FUNC_NAME s_scm_vm_restore_continuation_hook
-{
- VM_DEFINE_HOOK (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));
}
-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);
+
+ page_size = getpagesize ();
+ /* page_size should be a power of two. */
+ if (page_size & (page_size - 1))
+ abort ();
initialize_default_stack_size ();
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
- boot_continuation = make_boot_program ();
-
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
- vm_stack_gc_kind =
- GC_new_kind (GC_new_free_list (),
- GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
- 0, 1);
+ 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));
-#endif
+#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
}
void
#ifndef SCM_MAGIC_SNARFER
#include "libguile/vm.x"
#endif
-
- rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code);
- rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
- rtl_values = scm_i_make_rtl_program (rtl_values_code);
}
/*
HCoop / bpt / guile.git / blobdiff