* 02110-1301 USA
*/
+/* For mremap(2) on GNU/Linux systems. */
+#define _GNU_SOURCE
+
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
#include <stdint.h>
+#ifdef HAVE_SYS_MMAN_H
+#include <sys/mman.h>
+#endif
+
#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
#include "instructions.h"
#include "loader.h"
#include "programs.h"
+#include "simpos.h"
#include "vm.h"
#include "vm-builtins.h"
-#include "private-gc.h" /* scm_getenv_int */
-
static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
/* Unfortunately we can't snarf these: snarfed things are only loaded up from
/* #define VM_ENABLE_PARANOID_ASSERTIONS */
-/* 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
-
-/* 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
-
\f
/*
}
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));
vp->sp = cp->sp;
vp->fp = cp->fp;
}
}
+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,
scm_dynstack_capture_all (&thread->dynstack),
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 (struct scm_vm *vp, int hook_num, SCM *argv, int n)
&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,
}
\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
/*
* VM Error Handling
*/
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;
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)
{
* VM
*/
-#define VM_MIN_STACK_SIZE (1024)
-#define VM_DEFAULT_STACK_SIZE (256 * 1024)
-static size_t vm_stack_size = VM_DEFAULT_STACK_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: 4 or 8 kB. */
+static const size_t initial_stack_size = 1024;
+
+/* 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;
+ int 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;
}
+static void vm_expand_stack (struct scm_vm *vp) SCM_NOINLINE;
#define VM_NAME vm_regular_engine
#define VM_USE_HOOKS 0
#define FUNC_NAME "vm-regular-engine"
#undef VM_USE_HOOKS
#undef VM_NAME
-typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs);
+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[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)
+ SCM_SYSERROR;
+#else
+ ret = malloc (size);
+ if (!ret)
+ SCM_SYSERROR;
#endif
-static SCM
-make_vm (void)
-#define FUNC_NAME "make_vm"
+ 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 ();
+
+ old_size *= sizeof (SCM);
+ new_size *= sizeof (SCM);
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
- vp->stack_base = (SCM *)
- GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
+ new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE);
+ if (new_stack == MAP_FAILED)
+ SCM_SYSERROR;
- /* 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--;
+ return (SCM *) new_stack;
#else
- vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
- "stack-base");
+ SCM *new_stack;
+
+ new_stack = allocate_stack (new_size);
+ memcpy (new_stack, old_stack, old_size * sizeof (SCM));
+ free_stack (old_stack, old_size);
+
+ return new_stack;
#endif
+}
+#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_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
+ vp->stack_size = initial_stack_size;
+ vp->stack_base = allocate_stack (vp->stack_size);
+ 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)
+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)
{
- GC_word *word;
- const struct scm_vm *vm;
+ SCM *sp, *fp;
- /* The first word of the VM stack should contain a pointer to the
- corresponding VM. */
- vm = * ((struct scm_vm **) addr);
+ 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))
+ mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word *) elt,
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
+ }
+ sp = SCM_FRAME_PREVIOUS_SP (fp);
+ }
- 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;
+ return mark_stack_ptr;
+}
- 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);
+/* Free the VM stack, as this thread is exiting. */
+void
+scm_i_vm_free_stack (struct scm_vm *vp)
+{
+ free_stack (vp->stack_base, vp->stack_size);
+ vp->stack_base = vp->stack_limit = NULL;
+ vp->stack_size = 0;
+}
- return mark_stack_ptr;
+static void
+vm_expand_stack (struct scm_vm *vp)
+{
+ 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 ();
+ }
+
+ if (stack_size > vp->stack_size)
+ {
+ SCM *old_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;
+ vp->stack_base = expand_stack (old_stack, vp->stack_size, new_size);
+ vp->stack_size = new_size;
+ vp->stack_limit = vp->stack_base + new_size;
+ reloc = vp->stack_base - old_stack;
+
+ if (reloc)
+ {
+ SCM *fp;
+ vp->fp += reloc;
+ vp->sp += 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. */
}
-#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
+static struct scm_vm *
+thread_vm (scm_i_thread *t)
+{
+ if (SCM_UNLIKELY (!t->vp))
+ t->vp = make_vm ();
+ return t->vp;
+}
-SCM
-scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
+struct scm_vm *
+scm_the_vm (void)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- SCM_CHECK_STACK;
- return vm_engines[vp->engine](vm, program, argv, nargs);
+ return thread_vm (SCM_I_CURRENT_THREAD);
}
SCM
-scm_the_vm (void)
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ 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);
- if (SCM_UNLIKELY (scm_is_false (t->vm)))
- t->vm = make_vm ();
+ SCM_CHECK_STACK;
- return t->vm;
+ /* Check that we have enough space: 3 words for the boot
+ continuation, 3 + nargs for the procedure application, and 3 for
+ setting up a new frame. */
+ base_frame_size = 3 + 3 + nargs + 3;
+ vp->sp += base_frame_size;
+ if (vp->sp >= vp->stack_limit)
+ vm_expand_stack (vp);
+ 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];
+ vp->sp = &SCM_FRAME_LOCAL (vp->fp, nargs);
+
+ {
+ 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);
+ }
}
/* Scheme interface */
#define VM_DEFINE_HOOK(n) \
{ \
struct scm_vm *vp; \
- vp = SCM_VM_DATA (scm_the_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]; \
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 0, 0, 0,
- (void),
- "")
-#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", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_vm_trace_level
{
- return scm_from_int (SCM_VM_DATA (scm_the_vm ())->trace_level);
+ return scm_from_int (scm_the_vm ()->trace_level);
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_set_vm_trace_level_x
{
- SCM_VM_DATA (scm_the_vm ())->trace_level = scm_to_int (level);
+ scm_the_vm ()->trace_level = scm_to_int (level);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_vm_engine
{
- return vm_engine_to_symbol (SCM_VM_DATA (scm_the_vm ())->engine, FUNC_NAME);
+ return vm_engine_to_symbol (scm_the_vm ()->engine, FUNC_NAME);
}
#undef FUNC_NAME
SCM_MISC_ERROR ("Unknown VM engine: ~a",
scm_list_1 (scm_from_int (engine)));
- SCM_VM_DATA (scm_the_vm ())->engine = engine;
+ scm_the_vm ()->engine = engine;
}
#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));
}
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 =
- GC_new_kind (GC_new_free_list (),
- GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
- 0, 1);
-
-#endif
}
void
HCoop / bpt / guile.git / blobdiff