summaryrefslogtreecommitdiff
path: root/libguile/vm.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/vm.c')
-rw-r--r--libguile/vm.c95
1 files changed, 52 insertions, 43 deletions
diff --git a/libguile/vm.c b/libguile/vm.c
index 8fae65604..4d32c9545 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -83,9 +83,9 @@ static SCM sym_debug;
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
@@ -101,7 +101,8 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
*/
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;
@@ -124,6 +125,7 @@ scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
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);
}
@@ -183,10 +185,19 @@ vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
}
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
@@ -228,17 +239,19 @@ vm_dispatch_hook (SCM vm, int hook_num)
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;
@@ -261,16 +274,18 @@ vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
/* 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));
@@ -279,9 +294,10 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
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)) + cp->reloc + (base - cp->stack_base))
+ (((SCM *) (scm_p)) + reloc)
if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
scm_misc_error ("vm-engine",
@@ -312,30 +328,23 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
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
}
@@ -352,22 +361,22 @@ 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
@@ -392,7 +401,8 @@ really_make_boot_program (long nargs)
bp->metalen = 0;
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
- sizeof (struct scm_objcode) + sizeof (text));
+ 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);
@@ -504,7 +514,7 @@ make_vm (void)
/* 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
@@ -523,7 +533,6 @@ make_vm (void)
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