-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
#include <alloca.h>
#include <alignof.h>
#include <string.h>
+#include <stdint.h>
#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
#include "programs.h"
#include "vm.h"
-/* I sometimes use this for debugging. */
-#define vm_puts(OBJ) \
-{ \
- scm_display (OBJ, scm_current_error_port ()); \
- scm_newline (scm_current_error_port ()); \
-}
+static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
+
+/* Unfortunately we can't snarf these: snarfed things are only loaded up from
+ (system vm vm), which might not be loaded before an error happens. */
+static SCM sym_vm_run;
+static SCM sym_vm_error;
+static SCM sym_keyword_argument_error;
+static SCM sym_regular;
+static SCM sym_debug;
/* The VM has a number of internal assertions that shouldn't normally be
necessary, but might be if you think you found a bug in the VM. */
void
scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<vm-continuation ", port);
+ scm_puts_unlocked ("#<vm-continuation ", port);
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
/* In theory, a number of vm instances can be active in the call trace, and we
*/
SCM
scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
- scm_t_uint8 *mvra, scm_t_uint32 flags)
+ scm_t_uint8 *mvra, scm_t_dynstack *dynstack,
+ scm_t_uint32 flags)
{
struct scm_vm_cont *p;
p->fp = fp;
memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
p->reloc = p->stack_base - stack_base;
+ p->dynstack = dynstack;
p->flags = flags;
return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
}
SCM
-scm_i_vm_capture_continuation (SCM vm)
+scm_i_capture_current_stack (void)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, 0);
+ scm_i_thread *thread;
+ SCM vm;
+ struct scm_vm *vp;
+
+ thread = SCM_I_CURRENT_THREAD;
+ 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,
+ scm_dynstack_capture_all (&thread->dynstack),
+ 0);
}
static void
frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
frame->word_0 = SCM_PACK (scm_tc7_frame);
- frame->word_1 = PTR2SCM (&c_frame);
- args[0] = PTR2SCM (frame);
+ frame->word_1 = SCM_PACK_POINTER (&c_frame);
+ args[0] = SCM_PACK_POINTER (frame);
scm_c_run_hookn (hook, args, 1);
vp->trace_level = saved_trace_level;
}
-static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
static void
-vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
+vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) SCM_NORETURN;
+
+static void
+vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers)
{
size_t i;
ssize_t tail_len;
/* NULLSTACK (n + 1) */
SCM_VM_DATA (vm)->sp -= n + 1;
- scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
+ scm_c_abort (vm, tag, n + tail_len, argv, current_registers);
}
static void
-vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
- size_t n, SCM *argv, scm_t_int64 vm_cookie)
+vm_reinstate_partial_continuation (SCM vm, 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;
size_t i;
argv_copy = alloca (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_p + cp->reloc + (base - cp->stack_base))
+#define RELOC(scm_p) \
+ (((SCM *) (scm_p)) + reloc)
if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
scm_misc_error ("vm-engine",
vp->sp++;
*vp->sp = scm_from_size_t (n);
- /* Finally, rewind the dynamic state.
-
- We have to treat prompts specially, because we could be rewinding the
- dynamic state from a different thread, or just a different position on the
- C and/or VM stack -- so we need to reset the jump buffers so that an abort
- comes back here, with appropriately adjusted sp and fp registers. */
+ /* The prompt captured a slice of the dynamic stack. Here we wind
+ those entries onto the current thread's stack. We also have to
+ relocate any prompts that we see along the way. */
{
- long delta = 0;
- SCM newwinds = scm_i_dynwinds ();
- for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
+ scm_t_bits *walk;
+
+ for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
+ SCM_DYNSTACK_TAG (walk);
+ walk = SCM_DYNSTACK_NEXT (walk))
{
- SCM x = scm_car (intwinds);
- if (SCM_PROMPT_P (x))
- /* the jmpbuf will be reset by our caller */
- x = scm_c_make_prompt (SCM_PROMPT_TAG (x),
- RELOC (SCM_PROMPT_REGISTERS (x)->fp),
- RELOC (SCM_PROMPT_REGISTERS (x)->sp),
- SCM_PROMPT_REGISTERS (x)->ip,
- SCM_PROMPT_ESCAPE_P (x),
- vm_cookie,
- newwinds);
- newwinds = scm_cons (x, newwinds);
+ scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
+ scm_dynstack_wind_prompt (dynstack, walk, reloc, registers);
+ else
+ scm_dynstack_wind_1 (dynstack, walk);
}
- scm_dowinds (newwinds, delta);
}
#undef RELOC
}
* VM Internal functions
*/
-/* Unfortunately we can't snarf these: snarfed things are only loaded up from
- (system vm vm), which might not be loaded before an error happens. */
-static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;
-
void
scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
{
vm = SCM_VM_DATA (x);
- scm_puts ("#<vm ", port);
+ scm_puts_unlocked ("#<vm ", port);
switch (vm->engine)
{
case SCM_VM_REGULAR_ENGINE:
- scm_puts ("regular-engine ", port);
+ scm_puts_unlocked ("regular-engine ", port);
break;
case SCM_VM_DEBUG_ENGINE:
- scm_puts ("debug-engine ", port);
+ scm_puts_unlocked ("debug-engine ", port);
break;
default:
- scm_puts ("unknown-engine ", port);
+ scm_puts_unlocked ("unknown-engine ", port);
}
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
static SCM
text[1] = (scm_t_uint8)nargs;
- bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
+ bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
+ "boot-program");
memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
bp->len = sizeof(text);
bp->metalen = 0;
- u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
- sizeof (struct scm_objcode) + sizeof (text));
- ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
+ u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
+ sizeof (struct scm_objcode) + sizeof (text),
+ SCM_BOOL_F);
+ ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
static SCM
vm_make_boot_program (long nargs)
{
- static SCM programs[NUM_BOOT_PROGS] = { 0, };
+ static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
- if (SCM_UNLIKELY (!programs[0]))
+ if (SCM_UNLIKELY (scm_is_false (programs[0])))
{
int i;
for (i = 0; i < NUM_BOOT_PROGS; i++)
* VM
*/
+/* We are calling a SMOB. The calling code pushed the SMOB after the
+ args, and incremented nargs. That nargs is passed here. This
+ function's job is to replace the procedure with the trampoline, and
+ shuffle the smob itself to be argument 0. This function must not
+ allocate or throw, as the VM registers are not synchronized. */
+static void
+prepare_smob_call (SCM *sp, int nargs, SCM smob)
+{
+ SCM *args = sp - nargs + 1;
+
+ /* Shuffle args up. */
+ while (nargs--)
+ args[nargs + 1] = args[nargs];
+
+ args[0] = smob;
+ args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline;
+}
+
static SCM
resolve_variable (SCM what, SCM program_module)
{
/* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
top is. */
- *vp->stack_base = PTR2SCM (vp);
+ *vp->stack_base = SCM_PACK_POINTER (vp);
vp->stack_base++;
vp->stack_size--;
#else
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
- vp->engine = SCM_VM_DEBUG_ENGINE;
+ vp->engine = vm_default_engine;
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
- vp->cookie = 0;
return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
}
#undef FUNC_NAME
scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
+ SCM_CHECK_STACK;
return vm_engines[vp->engine](vm, program, argv, nargs);
}
-SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
- (SCM vm, SCM program, SCM args),
- "")
-#define FUNC_NAME s_scm_vm_apply
-{
- SCM *argv;
- int i, nargs;
-
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROC (2, program);
-
- 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);
- }
-
- return scm_c_vm_run (vm, program, argv, nargs);
-}
-#undef FUNC_NAME
-
/* Scheme interface */
-/* Return T's VM. */
-static inline SCM
-thread_vm (scm_i_thread *t)
-{
- if (SCM_UNLIKELY (scm_is_false (t->vm)))
- t->vm = make_vm ();
-
- return t->vm;
-}
-
-SCM_DEFINE (scm_thread_vm, "thread-vm", 1, 0, 0,
- (SCM thread),
- "Return @var{thread}'s VM.")
-#define FUNC_NAME s_scm_thread_vm
-{
- SCM_VALIDATE_THREAD (1, thread);
-
- return thread_vm (SCM_I_THREAD_DATA (thread));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_set_thread_vm_x, "set-thread-vm!", 2, 0, 0,
- (SCM thread, SCM vm),
- "Set @var{thread}'s VM to @var{vm}. Warning: Code being\n"
- "executed by @var{thread}'s current VM won't automatically\n"
- "switch to @var{vm}.")
-#define FUNC_NAME s_scm_set_thread_vm_x
-{
- scm_i_thread *t;
-
- SCM_VALIDATE_THREAD (1, thread);
- SCM_VALIDATE_VM (2, vm);
-
- t = SCM_I_THREAD_DATA (thread);
- t->vm = vm;
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
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 thread_vm (SCM_I_CURRENT_THREAD);
+ 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
#define FUNC_NAME s_scm_vm_ip
{
SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_vm_sp
{
SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_vm_fp
{
SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
}
#undef FUNC_NAME
#undef FUNC_NAME
\f
+/*
+ * VM engines
+ */
+
+static int
+symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
+{
+ if (scm_is_eq (engine, sym_regular))
+ return SCM_VM_REGULAR_ENGINE;
+ else if (scm_is_eq (engine, sym_debug))
+ return SCM_VM_DEBUG_ENGINE;
+ else
+ SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
+}
+
+static SCM
+vm_engine_to_symbol (int engine, const char *FUNC_NAME)
+{
+ switch (engine)
+ {
+ case SCM_VM_REGULAR_ENGINE:
+ return sym_regular;
+ case SCM_VM_DEBUG_ENGINE:
+ return sym_debug;
+ default:
+ /* ? */
+ SCM_MISC_ERROR ("Unknown VM engine: ~a",
+ scm_list_1 (scm_from_int (engine)));
+ }
+}
+
+SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_engine
+{
+ SCM_VALIDATE_VM (1, vm);
+ return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
+}
+#undef FUNC_NAME
+
+void
+scm_c_set_vm_engine_x (SCM vm, 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;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
+ (SCM vm, 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));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_c_set_default_vm_engine_x (int engine)
+#define FUNC_NAME "set-default-vm-engine!"
+{
+ if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
+ SCM_MISC_ERROR ("Unknown VM engine: ~a",
+ scm_list_1 (scm_from_int (engine)));
+
+ vm_default_engine = engine;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
+ (SCM engine),
+ "")
+#define FUNC_NAME s_scm_set_default_vm_engine_x
+{
+ scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
+ return SCM_UNSPECIFIED;
+}
+#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),
+ "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}.")
+#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;
+}
+#undef FUNC_NAME
+
+\f
/*
* Initialize
*/
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
- sym_vm_run = scm_from_locale_symbol ("vm-run");
- sym_vm_error = scm_from_locale_symbol ("vm-error");
- sym_keyword_argument_error = scm_from_locale_symbol ("keyword-argument-error");
- sym_debug = scm_from_locale_symbol ("debug");
+ sym_vm_run = scm_from_latin1_symbol ("vm-run");
+ sym_vm_error = scm_from_latin1_symbol ("vm-error");
+ sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
+ sym_regular = scm_from_latin1_symbol ("regular");
+ sym_debug = scm_from_latin1_symbol ("debug");
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
HCoop / bpt / guile.git / blobdiff