summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/Makefile.am2
-rw-r--r--libguile/continuations.c41
-rw-r--r--libguile/continuations.h3
-rw-r--r--libguile/control.c119
-rw-r--r--libguile/control.h28
-rw-r--r--libguile/dynstack.c544
-rw-r--r--libguile/dynstack.h206
-rw-r--r--libguile/dynwind.c226
-rw-r--r--libguile/dynwind.h16
-rw-r--r--libguile/eval.c55
-rw-r--r--libguile/fluids.c86
-rw-r--r--libguile/fluids.h19
-rw-r--r--libguile/print.c6
-rw-r--r--libguile/root.c12
-rw-r--r--libguile/stacks.c34
-rw-r--r--libguile/tags.h4
-rw-r--r--libguile/threads.c8
-rw-r--r--libguile/threads.h12
-rw-r--r--libguile/throw.c40
-rw-r--r--libguile/vm-i-system.c86
-rw-r--r--libguile/vm.c60
-rw-r--r--libguile/vm.h6
22 files changed, 1079 insertions, 534 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index df3e9d0e4..6d2da6620 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -133,6 +133,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
debug.c \
deprecated.c \
deprecation.c \
+ dynstack.c \
dynwind.c \
eq.c \
error.c \
@@ -529,6 +530,7 @@ modinclude_HEADERS = \
deprecated.h \
deprecation.h \
dynl.h \
+ dynstack.h \
dynwind.h \
eq.h \
error.h \
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 058e21e88..fe7618f5e 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -24,6 +24,7 @@
#include "libguile/_scm.h"
+#include <assert.h>
#include <string.h>
#include <stdio.h>
@@ -33,7 +34,7 @@
#include "libguile/stackchk.h"
#include "libguile/smob.h"
#include "libguile/ports.h"
-#include "libguile/dynwind.h"
+#include "libguile/dynstack.h"
#include "libguile/eval.h"
#include "libguile/vm.h"
#include "libguile/instructions.h"
@@ -52,7 +53,6 @@ static scm_t_bits tc16_continuation;
#define SCM_SET_CONTINUATION_LENGTH(x, n)\
(SCM_CONTREGS (x)->num_stack_items = (n))
#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
-#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
@@ -211,7 +211,6 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
+ (stack_size - 1) * sizeof (SCM_STACKITEM),
"continuation");
continuation->num_stack_items = stack_size;
- continuation->dynenv = scm_i_dynwinds ();
continuation->root = thread->continuation_root;
src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
@@ -334,33 +333,25 @@ grow_stack (SCM cont)
* own frame are overwritten. Thus, memcpy can be used for best performance.
*/
-typedef struct {
- scm_t_contregs *continuation;
- SCM_STACKITEM *dst;
-} copy_stack_data;
-
-static void
-copy_stack (void *data)
-{
- copy_stack_data *d = (copy_stack_data *)data;
- memcpy (d->dst, d->continuation->stack,
- sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
-#ifdef __ia64__
- SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
-#endif
-}
-
static void
copy_stack_and_call (scm_t_contregs *continuation,
SCM_STACKITEM * dst)
{
- long delta;
- copy_stack_data data;
+ scm_t_dynstack *dynstack;
+ scm_t_bits *joint;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ dynstack = SCM_VM_CONT_DATA (continuation->vm_cont)->dynstack;
+
+ joint = scm_dynstack_unwind_fork (&thread->dynstack, dynstack);
+
+ memcpy (dst, continuation->stack,
+ sizeof (SCM_STACKITEM) * continuation->num_stack_items);
+#ifdef __ia64__
+ thread->pending_rbs_continuation = continuation;
+#endif
- delta = scm_ilength (scm_i_dynwinds ()) - scm_ilength (continuation->dynenv);
- data.continuation = continuation;
- data.dst = dst;
- scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
+ scm_dynstack_wind (&thread->dynstack, joint);
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
diff --git a/libguile/continuations.h b/libguile/continuations.h
index e0a455632..29ea1c1a1 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -3,7 +3,7 @@
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 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
@@ -45,7 +45,6 @@
typedef struct
{
scm_i_jmp_buf jmpbuf;
- SCM dynenv;
#ifdef __ia64__
void *backing_store;
unsigned long backing_store_size;
diff --git a/libguile/control.c b/libguile/control.c
index ff6bfd89a..613ffbe4c 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -30,18 +30,18 @@
+#define PROMPT_ESCAPE_P(p) \
+ (SCM_DYNSTACK_TAG_FLAGS (SCM_DYNSTACK_TAG (p)) \
+ & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
-SCM
-scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
- scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie,
- SCM winds)
-{
- scm_t_bits tag;
- struct scm_prompt_registers *regs;
+
- tag = scm_tc7_prompt;
- if (escape_only_p)
- tag |= (SCM_F_PROMPT_ESCAPE<<8);
+
+scm_t_prompt_registers*
+scm_c_make_prompt_registers (SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
+ scm_t_int64 vm_cookie)
+{
+ scm_t_prompt_registers *regs;
regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
regs->fp = fp;
@@ -49,11 +49,10 @@ scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
regs->ip = abort_ip;
regs->cookie = vm_cookie;
- return scm_double_cell (tag, SCM_UNPACK (k), (scm_t_bits)regs,
- SCM_UNPACK (winds));
+ return regs;
}
-/* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
+/* Only to be called if the SCM_I_SETJMP returns 1 */
SCM
scm_i_prompt_pop_abort_args_x (SCM vm)
{
@@ -115,9 +114,9 @@ SCM_STATIC_OBJCODE (cont_objcode) = {
OBJCODE_HEADER (8, 19),
/* leave args on the stack */
/* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
- /* 2 */ scm_op_object_ref, 1, /* push internal winds */
- /* 4 */ scm_op_partial_cont_call, /* and go! */
- /* 5 */ scm_op_nop, scm_op_nop, scm_op_nop, /* pad to 8 bytes */
+ /* 2 */ scm_op_partial_cont_call, /* and go! */
+ /* 3 */ scm_op_nop,
+ /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, /* pad to 8 bytes */
/* 8 */
/* We could put some meta-info to say that this proc is a continuation. Not sure
@@ -125,7 +124,7 @@ SCM_STATIC_OBJCODE (cont_objcode) = {
META_HEADER (19),
/* 0 */ scm_op_make_eol, /* bindings */
/* 1 */ scm_op_make_eol, /* sources */
- /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 5, /* arity: from ip 0 to ip 7 */
+ /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip 3 */
/* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
/* 7 */ scm_op_make_int8_0, /* 0 optionals */
/* 8 */ scm_op_make_true, /* and a rest arg */
@@ -138,45 +137,35 @@ SCM_STATIC_OBJCODE (cont_objcode) = {
static SCM
-reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
+reify_partial_continuation (SCM vm, scm_t_prompt_registers *regs,
+ scm_t_dynstack *dynstack,
scm_t_int64 cookie)
{
- SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
+ SCM vm_cont, ret;
scm_t_uint32 flags;
- /* No need to reify if the continuation is never referenced in the handler. */
- if (SCM_PROMPT_ESCAPE_P (prompt))
- return SCM_BOOL_F;
-
- dynwinds = scm_i_dynwinds ();
- while (!scm_is_eq (dynwinds, extwinds))
- {
- intwinds = scm_cons (scm_car (dynwinds), intwinds);
- dynwinds = scm_cdr (dynwinds);
- }
-
flags = SCM_F_VM_CONT_PARTIAL;
- if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
+ if (cookie >= 0 && regs->cookie == cookie)
flags |= SCM_F_VM_CONT_REWINDABLE;
/* Since non-escape continuations should begin with a thunk application, the
first bit of the stack should be a frame, with the saved fp equal to the fp
that was current when the prompt was made. */
- if ((SCM*)SCM_UNPACK (SCM_PROMPT_REGISTERS (prompt)->sp[1])
- != SCM_PROMPT_REGISTERS (prompt)->fp)
+ if ((SCM*)SCM_UNPACK (regs->sp[1]) != regs->fp)
abort ();
/* Capture from the top of the thunk application frame up to the end. Set an
MVRA only, as the post-abort code is in an MV context. */
- vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp + 4,
+ vm_cont = scm_i_vm_capture_stack (regs->sp + 4,
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp,
NULL,
SCM_VM_DATA (vm)->ip,
+ dynstack,
flags);
ret = scm_make_program (cont_objcode,
- scm_vector (scm_list_2 (vm_cont, intwinds)),
+ scm_c_make_vector (1, vm_cont),
SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret,
SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION);
@@ -186,46 +175,42 @@ reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
void
scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
{
- SCM cont, winds, prompt = SCM_BOOL_F;
- long delta;
+ SCM cont;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ scm_t_bits *prompt;
+ scm_t_prompt_registers *regs;
+ scm_t_dynstack_prompt_flags flags;
size_t i;
- /* Search the wind list for an appropriate prompt.
- "Waiter, please bring us the wind list." */
- for (winds = scm_i_dynwinds (), delta = 0;
- scm_is_pair (winds);
- winds = SCM_CDR (winds), delta++)
- {
- SCM elt = SCM_CAR (winds);
- if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
- {
- prompt = elt;
- break;
- }
- }
-
- /* If we didn't find anything, raise an error. */
- if (scm_is_false (prompt))
+ prompt = scm_dynstack_find_prompt (dynstack, tag, &regs, &flags);
+
+ if (!prompt)
scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
- cont = reify_partial_continuation (vm, prompt, winds, cookie);
+ /* Only reify if the continuation referenced in the handler. */
+ if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
+ cont = SCM_BOOL_F;
+ else
+ {
+ scm_t_dynstack *captured;
- /* Unwind once more, beyond the prompt. */
- winds = SCM_CDR (winds), delta++;
+ captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
+ cont = reify_partial_continuation (vm, regs, captured, cookie);
+ }
- /* Unwind */
- scm_dowinds (winds, delta);
+ /* Unwind. */
+ scm_dynstack_unwind (dynstack, prompt);
/* Unwinding may have changed the current thread's VM, so use the
new one. */
vm = scm_the_vm ();
/* Restore VM regs */
- SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
- SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
- SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;
+ SCM_VM_DATA (vm)->fp = regs->fp;
+ SCM_VM_DATA (vm)->sp = regs->sp;
+ SCM_VM_DATA (vm)->ip = regs->ip;
- /* Since we're jumping down, we should always have enough space */
+ /* Since we're jumping down, we should always have enough space. */
if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
abort ();
@@ -236,7 +221,7 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
*(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
/* Jump! */
- SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);
+ SCM_I_LONGJMP (regs->regs, 1);
/* Shouldn't get here */
abort ();
@@ -266,14 +251,6 @@ SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
#undef FUNC_NAME
void
-scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts_unlocked ("#<prompt ", port);
- scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc_unlocked ('>', port);
-}
-
-void
scm_init_control (void)
{
#include "libguile/control.x"
diff --git a/libguile/control.h b/libguile/control.h
index ebf255f72..a91285588 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 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
@@ -20,32 +20,21 @@
#define SCM_CONTROL_H
-#define SCM_F_PROMPT_ESCAPE 0x1
-
-#define SCM_PROMPT_P(x) (SCM_HAS_TYP7 (x, scm_tc7_prompt))
-#define SCM_PROMPT_FLAGS(x) (SCM_CELL_WORD ((x), 0) >> 8)
-#define SCM_PROMPT_ESCAPE_P(x) (SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
-#define SCM_PROMPT_TAG(x) (SCM_CELL_OBJECT ((x), 1))
-#define SCM_PROMPT_REGISTERS(x) ((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
-#define SCM_PROMPT_DYNWINDS(x) (SCM_CELL_OBJECT ((x), 3))
-
-#define SCM_PROMPT_SETJMP(p) (SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))
-
-struct scm_prompt_registers
+typedef struct
{
scm_t_uint8 *ip;
SCM *sp;
SCM *fp;
scm_t_int64 cookie;
scm_i_jmp_buf regs;
-};
+} scm_t_prompt_registers;
+
+SCM_INTERNAL scm_t_prompt_registers*
+scm_c_make_prompt_registers (SCM *fp, SCM *sp,
+ scm_t_uint8 *abort_ip,
+ scm_t_int64 vm_cookie);
-SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp,
- scm_t_uint8 *abort_ip,
- scm_t_uint8 escape_only_p,
- scm_t_int64 vm_cookie,
- SCM winds);
SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM vm);
SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
@@ -53,7 +42,6 @@ SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN;
-SCM_INTERNAL void scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_control (void);
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
new file mode 100644
index 000000000..56e007c1f
--- /dev/null
+++ b/libguile/dynstack.c
@@ -0,0 +1,544 @@
+/* Copyright (C) 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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/control.h"
+#include "libguile/eval.h"
+#include "libguile/fluids.h"
+#include "libguile/dynstack.h"
+
+
+
+
+#define PROMPT_WORDS 2
+#define PROMPT_KEY(top) (SCM_PACK ((top)[0]))
+#define PROMPT_REGS(top) ((scm_t_prompt_registers*) ((top)[1]))
+
+#define WINDER_WORDS 2
+#define WINDER_PROC(top) ((scm_t_guard) ((top)[0]))
+#define WINDER_DATA(top) ((void *) ((top)[1]))
+
+#define DYNWIND_WORDS 2
+#define DYNWIND_ENTER(top) (SCM_PACK ((top)[0]))
+#define DYNWIND_LEAVE(top) (SCM_PACK ((top)[1]))
+
+#define WITH_FLUIDS_FLUIDS(top) ((SCM*)((top) + 1))
+#define WITH_FLUIDS_VALUES(top) ((SCM*)((top)[0]))
+
+
+
+
+static void
+copy_scm_t_bits (scm_t_bits *dst, scm_t_bits *src, size_t n)
+{
+ size_t i;
+
+ for (i = 0; i < n; i++)
+ dst[i] = src[i];
+}
+
+static void
+copy_scm (SCM *dst, SCM *src, size_t n)
+{
+ size_t i;
+
+ for (i = 0; i < n; i++)
+ dst[i] = src[i];
+}
+
+static void
+clear_scm_t_bits (scm_t_bits *items, size_t n)
+{
+ size_t i;
+
+ for (i = 0; i < n; i++)
+ items[i] = 0;
+}
+
+/* Ensure space for N additional words. */
+static void
+dynstack_ensure_space (scm_t_dynstack *dynstack, size_t n)
+{
+ size_t capacity = SCM_DYNSTACK_CAPACITY (dynstack);
+ size_t height = SCM_DYNSTACK_HEIGHT (dynstack);
+
+ n += SCM_DYNSTACK_HEADER_LEN;
+
+ if (capacity < height + n)
+ {
+ scm_t_bits *new_base;
+
+ while (capacity < height + n)
+ capacity = (capacity < 4) ? 8 : (capacity * 2);
+
+ new_base = scm_gc_malloc (capacity * sizeof(scm_t_bits), "dynstack");
+
+ copy_scm_t_bits (new_base, dynstack->base, height);
+ clear_scm_t_bits (dynstack->base, height);
+
+ dynstack->base = new_base;
+ dynstack->top = new_base + height;
+ dynstack->limit = new_base + capacity;
+ }
+}
+
+static inline scm_t_bits *
+push_dynstack_entry_unchecked (scm_t_dynstack *dynstack,
+ scm_t_dynstack_item_type type,
+ scm_t_bits flags, size_t len)
+{
+ scm_t_bits *ret = dynstack->top;
+
+ SCM_DYNSTACK_SET_TAG (dynstack->top, SCM_MAKE_DYNSTACK_TAG (type, flags, len));
+ dynstack->top += SCM_DYNSTACK_HEADER_LEN + len;
+ SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, SCM_DYNSTACK_HEADER_LEN + len);
+
+ return ret;
+}
+
+static inline scm_t_bits *
+push_dynstack_entry (scm_t_dynstack *dynstack,
+ scm_t_dynstack_item_type type,
+ scm_t_bits flags, size_t len)
+{
+ if (SCM_UNLIKELY (!SCM_DYNSTACK_HAS_SPACE (dynstack, len)))
+ dynstack_ensure_space (dynstack, len);
+ return push_dynstack_entry_unchecked (dynstack, type, flags, len);
+}
+
+void
+scm_dynstack_push_frame (scm_t_dynstack *dynstack,
+ scm_t_dynstack_frame_flags flags)
+{
+ push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_FRAME, flags, 0);
+}
+
+void
+scm_dynstack_push_rewinder (scm_t_dynstack *dynstack,
+ scm_t_dynstack_winder_flags flags,
+ scm_t_guard proc, void *data)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_REWINDER, flags, 2);
+ words[0] = (scm_t_bits) proc;
+ words[1] = (scm_t_bits) data;
+}
+
+void
+scm_dynstack_push_unwinder (scm_t_dynstack *dynstack,
+ scm_t_dynstack_winder_flags flags,
+ scm_t_guard proc, void *data)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_UNWINDER, flags, 2);
+ words[0] = (scm_t_bits) proc;
+ words[1] = (scm_t_bits) data;
+}
+
+/* The fluids are stored on the stack. However, the values have to be
+ stored on the heap, so that all continuations that capture this
+ dynamic scope capture the same bindings. */
+void
+scm_dynstack_push_fluids (scm_t_dynstack *dynstack, size_t n,
+ SCM *fluids, SCM *values, SCM dynamic_state)
+{
+ scm_t_bits *words;
+ SCM *heap_values;
+
+ n = scm_prepare_fluids (n, fluids, values);
+ heap_values = scm_gc_malloc (n * sizeof (scm_t_bits), "with-fluids");
+ copy_scm (heap_values, values, n);
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUIDS,
+ 0, n + 1);
+ words[0] = (scm_t_bits) heap_values;
+ copy_scm (WITH_FLUIDS_FLUIDS (words), fluids, n);
+
+ /* Go ahead and swap them. */
+ scm_swap_fluids (n, WITH_FLUIDS_FLUIDS (words), WITH_FLUIDS_VALUES (words),
+ dynamic_state);
+}
+
+void
+scm_dynstack_push_prompt (scm_t_dynstack *dynstack,
+ scm_t_dynstack_prompt_flags flags,
+ SCM key, scm_t_prompt_registers *regs)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_PROMPT, flags, 2);
+ words[0] = SCM_UNPACK (key);
+ words[1] = (scm_t_bits) regs;
+}
+
+void
+scm_dynstack_push_dynwind (scm_t_dynstack *dynstack, SCM enter, SCM leave)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNWIND, 0, 2);
+ words[0] = SCM_UNPACK (enter);
+ words[1] = SCM_UNPACK (leave);
+}
+
+static inline scm_t_bits
+dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words)
+{
+ scm_t_bits *prev = SCM_DYNSTACK_PREV (dynstack->top);
+ scm_t_bits tag;
+
+ if (SCM_UNLIKELY (!prev))
+ abort ();
+
+ SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, 0);
+ dynstack->top = prev;
+
+ tag = SCM_DYNSTACK_TAG (dynstack->top);
+ SCM_DYNSTACK_SET_TAG (dynstack->top, 0);
+ *words = dynstack->top;
+
+ return tag;
+}
+
+void
+scm_dynstack_pop (scm_t_dynstack *dynstack)
+{
+ scm_t_bits tag, *words;
+ tag = dynstack_pop (dynstack, &words);
+ clear_scm_t_bits (words, SCM_DYNSTACK_TAG_LEN (tag));
+}
+
+scm_t_dynstack *
+scm_dynstack_capture_all (scm_t_dynstack *dynstack)
+{
+ return scm_dynstack_capture (dynstack, SCM_DYNSTACK_FIRST (dynstack));
+}
+
+scm_t_dynstack *
+scm_dynstack_capture (scm_t_dynstack *dynstack, scm_t_bits *item)
+{
+ char *mem;
+ scm_t_dynstack *ret;
+ size_t len;
+
+ assert (item >= SCM_DYNSTACK_FIRST (dynstack));
+ assert (item <= dynstack->top);
+
+ len = dynstack->top - item + SCM_DYNSTACK_HEADER_LEN;
+ mem = scm_gc_malloc (sizeof (*ret) + len * sizeof(scm_t_bits), "dynstack");
+ ret = (scm_t_dynstack *) mem;
+ ret->base = (scm_t_bits *) (mem + sizeof (*ret));
+ ret->limit = ret->base + len;
+ ret->top = ret->base + len;
+
+ copy_scm_t_bits (ret->base, item - SCM_DYNSTACK_HEADER_LEN, len);
+ SCM_DYNSTACK_SET_PREV_OFFSET (SCM_DYNSTACK_FIRST (ret), 0);
+
+ return ret;
+}
+
+void
+scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
+{
+ scm_t_bits tag = SCM_DYNSTACK_TAG (item);
+ scm_t_dynstack_item_type type = SCM_DYNSTACK_TAG_TYPE (tag);
+ scm_t_bits flags = SCM_DYNSTACK_TAG_FLAGS (tag);
+ size_t len = SCM_DYNSTACK_TAG_LEN (tag);
+
+ switch (type)
+ {
+ case SCM_DYNSTACK_TYPE_FRAME:
+ if (!(flags & SCM_F_DYNSTACK_FRAME_REWINDABLE))
+ scm_misc_error ("scm_dynstack_wind_1",
+ "cannot invoke continuation from this context",
+ SCM_EOL);
+ break;
+
+ case SCM_DYNSTACK_TYPE_UNWINDER:
+ break;
+
+ case SCM_DYNSTACK_TYPE_REWINDER:
+ WINDER_PROC (item) (WINDER_DATA (item));
+ break;
+
+ case SCM_DYNSTACK_TYPE_WITH_FLUIDS:
+ scm_swap_fluids (len - 1, WITH_FLUIDS_FLUIDS (item),
+ WITH_FLUIDS_VALUES (item),
+ SCM_I_CURRENT_THREAD->dynamic_state);
+ break;
+
+ case SCM_DYNSTACK_TYPE_PROMPT:
+ /* see vm_reinstate_partial_continuation */
+ break;
+
+ case SCM_DYNSTACK_TYPE_DYNWIND:
+ scm_call_0 (DYNWIND_ENTER (item));
+ break;
+
+ case SCM_DYNSTACK_TYPE_NONE:
+ default:
+ abort ();
+ }
+
+ {
+ scm_t_bits *words = push_dynstack_entry (dynstack, type, flags, len);
+
+ copy_scm_t_bits (words, item, len);
+ }
+}
+
+scm_t_bits
+scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
+{
+ scm_t_bits tag;
+ scm_t_bits *words;
+ scm_t_dynstack_item_type type;
+ size_t len;
+
+ tag = dynstack_pop (dynstack, &words);
+
+ type = SCM_DYNSTACK_TAG_TYPE (tag);
+ len = SCM_DYNSTACK_TAG_LEN (tag);
+
+ switch (type)
+ {
+ case SCM_DYNSTACK_TYPE_FRAME:
+ break;
+
+ case SCM_DYNSTACK_TYPE_UNWINDER:
+ WINDER_PROC (words) (WINDER_DATA (words));
+ clear_scm_t_bits (words, WINDER_WORDS);
+ break;
+
+ case SCM_DYNSTACK_TYPE_REWINDER:
+ clear_scm_t_bits (words, WINDER_WORDS);
+ break;
+
+ case SCM_DYNSTACK_TYPE_WITH_FLUIDS:
+ scm_swap_fluids (len - 1, WITH_FLUIDS_FLUIDS (words),
+ WITH_FLUIDS_VALUES (words),
+ SCM_I_CURRENT_THREAD->dynamic_state);
+ clear_scm_t_bits (words, len);
+ break;
+
+ case SCM_DYNSTACK_TYPE_PROMPT:
+ /* we could invalidate the prompt */
+ clear_scm_t_bits (words, PROMPT_WORDS);
+ break;
+
+ case SCM_DYNSTACK_TYPE_DYNWIND:
+ {
+ SCM proc = DYNWIND_LEAVE (words);
+ clear_scm_t_bits (words, DYNWIND_WORDS);
+ scm_call_0 (proc);
+ }
+ break;
+
+ case SCM_DYNSTACK_TYPE_NONE:
+ default:
+ abort ();
+ }
+
+ return tag;
+}
+
+void
+scm_dynstack_wind (scm_t_dynstack *dynstack, scm_t_bits *item)
+{
+ for (; SCM_DYNSTACK_TAG (item); item = SCM_DYNSTACK_NEXT (item))
+ scm_dynstack_wind_1 (dynstack, item);
+}
+
+void
+scm_dynstack_unwind (scm_t_dynstack *dynstack, scm_t_bits *base)
+{
+ while (dynstack->top > base)
+ scm_dynstack_unwind_1 (dynstack);
+}
+
+static int
+same_entries (scm_t_bits *walk_a, scm_t_bits *next_a,
+ scm_t_bits *walk_b, scm_t_bits *next_b)
+{
+ if (SCM_DYNSTACK_TAG (walk_a) != SCM_DYNSTACK_TAG (walk_b))
+ return 0;
+
+ if (next_a - walk_a != next_b - walk_b)
+ return 0;
+
+ assert (SCM_DYNSTACK_PREV_OFFSET (next_a) == next_a - walk_a);
+ assert (SCM_DYNSTACK_PREV_OFFSET (next_b) == next_b - walk_b);
+
+ while (walk_a != next_a)
+ if (*(walk_a++) != *(walk_b++))
+ return 0;
+
+ return 1;
+}
+
+static ptrdiff_t
+shared_prefix_length (scm_t_dynstack *a, scm_t_dynstack *b)
+{
+ scm_t_bits *walk_a, *next_a, *walk_b, *next_b;
+
+ walk_a = SCM_DYNSTACK_FIRST (a);
+ walk_b = SCM_DYNSTACK_FIRST (b);
+
+ next_a = SCM_DYNSTACK_NEXT (walk_a);
+ next_b = SCM_DYNSTACK_NEXT (walk_b);
+
+ while (next_a && next_b && same_entries (walk_a, next_a, walk_b, next_b))
+ {
+ walk_a = next_a;
+ walk_b = next_b;
+
+ next_a = SCM_DYNSTACK_NEXT (walk_a);
+ next_b = SCM_DYNSTACK_NEXT (walk_b);
+ }
+
+ return walk_a - a->base;
+}
+
+scm_t_bits *
+scm_dynstack_unwind_fork (scm_t_dynstack *dynstack, scm_t_dynstack *branch)
+{
+ ptrdiff_t join_height;
+
+ join_height = shared_prefix_length (dynstack, branch);
+
+ scm_dynstack_unwind (dynstack, dynstack->base + join_height);
+
+ return branch->base + join_height;
+}
+
+scm_t_bits*
+scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key,
+ scm_t_prompt_registers **regs,
+ scm_t_dynstack_prompt_flags *flags)
+{
+ scm_t_bits *walk;
+
+ for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk;
+ walk = SCM_DYNSTACK_PREV (walk))
+ {
+ scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT
+ && scm_is_eq (PROMPT_KEY (walk), key))
+ {
+ if (regs)
+ *regs = PROMPT_REGS (walk);
+ if (flags)
+ *flags = SCM_DYNSTACK_TAG_FLAGS (tag);
+ return walk;
+ }
+ }
+
+ return NULL;
+}
+
+scm_t_prompt_registers*
+scm_dynstack_relocate_prompt (scm_t_dynstack *dynstack, scm_t_ptrdiff reloc,
+ scm_t_uint64 vm_cookie)
+{
+ scm_t_bits *item;
+ scm_t_prompt_registers *prev, *rewound;
+
+ item = SCM_DYNSTACK_PREV (dynstack->top);
+ if (SCM_DYNSTACK_TAG_TYPE (SCM_DYNSTACK_TAG (item))
+ != SCM_DYNSTACK_TYPE_PROMPT)
+ abort ();
+
+ prev = PROMPT_REGS (item);
+ rewound = scm_c_make_prompt_registers (prev->fp + reloc,
+ prev->sp + reloc,
+ prev->ip,
+ vm_cookie);
+ item[1] = (scm_t_bits) rewound;
+
+ return rewound;
+}
+
+void
+scm_dynstack_unwind_frame (scm_t_dynstack *dynstack)
+{
+ /* Unwind up to and including the next frame entry. */
+ while (1)
+ {
+ scm_t_bits tag, *words;
+
+ tag = dynstack_pop (dynstack, &words);
+
+ switch (SCM_DYNSTACK_TAG_TYPE (tag))
+ {
+ case SCM_DYNSTACK_TYPE_FRAME:
+ return;
+ case SCM_DYNSTACK_TYPE_REWINDER:
+ clear_scm_t_bits (words, WINDER_WORDS);
+ continue;
+ case SCM_DYNSTACK_TYPE_UNWINDER:
+ {
+ scm_t_guard proc = WINDER_PROC (words);
+ void *data = WINDER_DATA (words);
+ clear_scm_t_bits (words, WINDER_WORDS);
+ if (SCM_DYNSTACK_TAG_FLAGS (tag) & SCM_F_DYNSTACK_WINDER_EXPLICIT)
+ proc (data);
+ continue;
+ }
+ default:
+ /* We should only see winders. */
+ abort ();
+ }
+ }
+}
+
+/* This function must not allocate. */
+void
+scm_dynstack_unwind_fluids (scm_t_dynstack *dynstack, SCM dynamic_state)
+{
+ scm_t_bits tag, *words;
+ size_t len;
+
+ tag = dynstack_pop (dynstack, &words);
+ len = SCM_DYNSTACK_TAG_LEN (tag);
+
+ assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_WITH_FLUIDS);
+ assert (len >= 1);
+
+ scm_swap_fluids (len - 1, WITH_FLUIDS_FLUIDS (words),
+ WITH_FLUIDS_VALUES (words), dynamic_state);
+ clear_scm_t_bits (words, len);
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
new file mode 100644
index 000000000..33389cad7
--- /dev/null
+++ b/libguile/dynstack.h
@@ -0,0 +1,206 @@
+/* classes: h_files */
+
+#ifndef SCM_DYNSTACK_H
+#define SCM_DYNSTACK_H
+
+/* Copyright (C) 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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+#include "libguile/control.h"
+
+
+
+typedef struct
+{
+ scm_t_bits *base;
+ scm_t_bits *top;
+ scm_t_bits *limit;
+} scm_t_dynstack;
+
+
+
+/* Items on the dynstack are preceded by two-word headers, giving the
+ offset of the preceding item (or 0 if there is none) and the type,
+ flags, and length of the following dynstack entry, in words. In
+ addition, there is a "null header" at the top of the stack,
+ indicating the length of the previous item, but with a tag of zero.
+
+ For example, consider an empty dynstack, with a capacity of 6 words:
+
+ +----------+----------+ +
+ |prev=0 |tag=0 | |
+ +----------+----------+ +
+ ^base ^top limit^
+
+ Now we evaluate (dynamic-wind enter thunk leave). That will result
+ in a dynstack of:
+
+ / the len=2 words \
+ +----------+----------+----------+----------+----------+----------+
+ |prev=0 |tag:len=2 |enter |leave |prev=4 |tag=0 |
+ +----------+----------+----------+----------+----------+----------+
+ ^base top,limit^
+
+ The tag is a combination of the type of the dynstack item, some flags
+ associated with the item, and the length of the item. See
+ SCM_MAKE_DYNSTACK_TAG below for the details.
+
+ This arrangement makes it possible to have variable-length dynstack
+ items, and yet be able to traverse them forwards or backwards. */
+
+#define SCM_DYNSTACK_HEADER_LEN 2
+
+#define SCM_DYNSTACK_PREV_OFFSET(top) ((top)[-2])
+#define SCM_DYNSTACK_SET_PREV_OFFSET(top, offset) (top)[-2] = (offset)
+
+#define SCM_DYNSTACK_TAG(top) ((top)[-1])
+#define SCM_DYNSTACK_SET_TAG(top, tag) (top)[-1] = (tag)
+
+typedef enum {
+ SCM_DYNSTACK_TYPE_NONE = 0,
+ SCM_DYNSTACK_TYPE_FRAME,
+ SCM_DYNSTACK_TYPE_UNWINDER,
+ SCM_DYNSTACK_TYPE_REWINDER,
+ SCM_DYNSTACK_TYPE_WITH_FLUIDS,
+ SCM_DYNSTACK_TYPE_PROMPT,
+ SCM_DYNSTACK_TYPE_DYNWIND,
+} scm_t_dynstack_item_type;
+
+#define SCM_DYNSTACK_TAG_TYPE_MASK 0xf
+#define SCM_DYNSTACK_TAG_FLAGS_MASK 0xf0
+#define SCM_DYNSTACK_TAG_FLAGS_SHIFT 4
+#define SCM_DYNSTACK_TAG_LEN_SHIFT 8
+
+#define SCM_MAKE_DYNSTACK_TAG(type, flags, len) \
+ ((type) | (flags) | ((len) << SCM_DYNSTACK_TAG_LEN_SHIFT))
+
+#define SCM_DYNSTACK_TAG_TYPE(tag) \
+ ((tag) & SCM_DYNSTACK_TAG_TYPE_MASK)
+#define SCM_DYNSTACK_TAG_FLAGS(tag) \
+ ((tag) & SCM_DYNSTACK_TAG_FLAGS_MASK)
+#define SCM_DYNSTACK_TAG_LEN(tag) \
+ ((tag) >> SCM_DYNSTACK_TAG_LEN_SHIFT)
+
+#define SCM_DYNSTACK_PREV(top) \
+ (SCM_DYNSTACK_PREV_OFFSET (top) \
+ ? ((top) - SCM_DYNSTACK_PREV_OFFSET (top)) : NULL)
+#define SCM_DYNSTACK_NEXT(top) \
+ (SCM_DYNSTACK_TAG (top) \
+ ? ((top) + SCM_DYNSTACK_TAG_LEN (SCM_DYNSTACK_TAG (top)) \
+ + SCM_DYNSTACK_HEADER_LEN) \
+ : NULL)
+
+#define SCM_DYNSTACK_FIRST(dynstack) \
+ ((dynstack)->base + SCM_DYNSTACK_HEADER_LEN)
+
+#define SCM_DYNSTACK_CAPACITY(dynstack) \
+ ((dynstack)->limit - (dynstack)->base)
+#define SCM_DYNSTACK_SPACE(dynstack) \
+ ((dynstack)->limit - (dynstack)->top)
+#define SCM_DYNSTACK_HEIGHT(dynstack) \
+ ((dynstack)->top - (dynstack)->base)
+
+#define SCM_DYNSTACK_HAS_SPACE(dynstack, n) \
+ (SCM_DYNSTACK_SPACE (dynstack) >= n + SCM_DYNSTACK_HEADER_LEN)
+
+typedef enum {
+ SCM_F_DYNSTACK_FRAME_REWINDABLE = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+} scm_t_dynstack_frame_flags;
+
+typedef enum {
+ SCM_F_DYNSTACK_WINDER_EXPLICIT = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+} scm_t_dynstack_winder_flags;
+
+typedef enum {
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+} scm_t_dynstack_prompt_flags;
+
+typedef void (*scm_t_guard) (void *);
+
+
+
+
+/* Pushing and popping entries on the dynamic stack. */
+
+SCM_INTERNAL void scm_dynstack_push_frame (scm_t_dynstack *,
+ scm_t_dynstack_frame_flags);
+SCM_INTERNAL void scm_dynstack_push_rewinder (scm_t_dynstack *,
+ scm_t_dynstack_winder_flags,
+ scm_t_guard, void *);
+SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *,
+ scm_t_dynstack_winder_flags,
+ scm_t_guard, void *);
+SCM_INTERNAL void scm_dynstack_push_fluids (scm_t_dynstack *,
+ size_t,
+ SCM *fluids,
+ SCM *values,
+ SCM dynamic_state);
+SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *,
+ scm_t_dynstack_prompt_flags,
+ SCM key,
+ scm_t_prompt_registers *);
+SCM_INTERNAL void scm_dynstack_push_dynwind (scm_t_dynstack *,
+ SCM enter, SCM leave);
+
+SCM_INTERNAL void scm_dynstack_pop (scm_t_dynstack *);
+
+
+
+
+/* Capturing, winding, and unwinding. */
+
+SCM_INTERNAL scm_t_dynstack* scm_dynstack_capture_all (scm_t_dynstack *dynstack);
+SCM_INTERNAL scm_t_dynstack* scm_dynstack_capture (scm_t_dynstack *dynstack,
+ scm_t_bits *item);
+
+SCM_INTERNAL void scm_dynstack_wind_1 (scm_t_dynstack *, scm_t_bits *);
+SCM_INTERNAL scm_t_bits scm_dynstack_unwind_1 (scm_t_dynstack *);
+
+SCM_INTERNAL void scm_dynstack_wind (scm_t_dynstack *, scm_t_bits *);
+SCM_INTERNAL void scm_dynstack_unwind (scm_t_dynstack *, scm_t_bits *);
+
+SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *,
+ scm_t_dynstack *);
+
+SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *);
+SCM_INTERNAL void scm_dynstack_unwind_fluids (scm_t_dynstack *dynstack,
+ SCM dynamic_state);
+
+
+
+
+/* Miscellany. */
+
+SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM,
+ scm_t_prompt_registers **,
+ scm_t_dynstack_prompt_flags *);
+
+SCM_INTERNAL scm_t_prompt_registers*
+scm_dynstack_relocate_prompt (scm_t_dynstack *, scm_t_ptrdiff, scm_t_uint64);
+
+
+#endif /* SCM_DYNSTACK_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index bec2dc806..05791860a 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -1,5 +1,5 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 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
* as published by the Free Software Foundation; either version 3 of
@@ -26,125 +26,72 @@
#include <assert.h>
#include "libguile/_scm.h"
-#include "libguile/control.h"
+#include "libguile/dynstack.h"
#include "libguile/eval.h"
-#include "libguile/alist.h"
-#include "libguile/fluids.h"
#include "libguile/ports.h"
-#include "libguile/smob.h"
#include "libguile/dynwind.h"
-
-
-/* {Dynamic wind}
-
- Things that can be on the wind list:
-
- #<frame>
- #<winder>
- #<with-fluids>
- #<prompt>
- (enter-proc . leave-proc) dynamic-wind
-
-*/
+
SCM
scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
#define FUNC_NAME "dynamic-wind"
{
- SCM ans, old_winds;
- SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
- out_guard,
+ SCM ans;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)), out_guard,
SCM_ARG3, FUNC_NAME);
+
scm_call_0 (in_guard);
- old_winds = scm_i_dynwinds ();
- scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
+ scm_dynstack_push_dynwind (&thread->dynstack, in_guard, out_guard);
+
ans = scm_call_0 (thunk);
- scm_i_set_dynwinds (old_winds);
+
+ scm_dynstack_pop (&thread->dynstack);
scm_call_0 (out_guard);
+
return ans;
}
#undef FUNC_NAME
-/* Frames and winders. */
-
-static scm_t_bits tc16_frame;
-#define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f))
-
-#define FRAME_F_REWINDABLE (1 << 0)
-#define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
-
-static scm_t_bits tc16_winder;
-#define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w))
-#define WINDER_PROC(w) ((void (*)(void *))SCM_SMOB_DATA (w))
-#define WINDER_DATA(w) ((void *)SCM_SMOB_DATA_2 (w))
-
-#define WINDER_F_EXPLICIT (1 << 0)
-#define WINDER_F_REWIND (1 << 1)
-#define WINDER_F_MARK (1 << 2)
-#define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
-#define WINDER_REWIND_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
-#define WINDER_MARK_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
void
scm_dynwind_begin (scm_t_dynwind_flags flags)
{
- SCM f;
- SCM_NEWSMOB (f, tc16_frame, 0);
- if (flags & SCM_F_DYNWIND_REWINDABLE)
- SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
- scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ scm_dynstack_push_frame (&thread->dynstack, flags);
}
+/* FIXME -- breaking abstractions */
void
scm_dynwind_end (void)
{
- SCM winds;
-
- /* Unwind upto and including the next frame entry. We can only
- encounter #<winder> entries on the way.
- */
-
- winds = scm_i_dynwinds ();
- while (scm_is_pair (winds))
- {
- SCM entry = SCM_CAR (winds);
- winds = SCM_CDR (winds);
-
- scm_i_set_dynwinds (winds);
-
- if (FRAME_P (entry))
- return;
-
- assert (WINDER_P (entry));
- if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
- WINDER_PROC(entry) (WINDER_DATA (entry));
- }
-
- assert (0);
+ scm_dynstack_unwind_frame (&SCM_I_CURRENT_THREAD->dynstack);
}
void
scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
scm_t_wind_flags flags)
{
- SCM w;
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
- if (flags & SCM_F_WIND_EXPLICITLY)
- SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_t_dynstack *dynstack = &thread->dynstack;
+
+ scm_dynstack_push_unwinder (dynstack, flags, proc, data);
}
void
scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
scm_t_wind_flags flags)
{
- SCM w;
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
- SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_t_dynstack *dynstack = &thread->dynstack;
+
+ scm_dynstack_push_rewinder (dynstack, 0, proc, data);
+
if (flags & SCM_F_WIND_EXPLICITLY)
proc (data);
}
@@ -153,23 +100,16 @@ void
scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
scm_t_wind_flags flags)
{
- SCM w;
- scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
- SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
+ /* FIXME: This is not a safe cast. */
+ scm_dynwind_unwind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
}
void
scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
scm_t_wind_flags flags)
{
- SCM w;
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
- SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
- if (flags & SCM_F_WIND_EXPLICITLY)
- proc (data);
+ /* FIXME: This is not a safe cast. */
+ scm_dynwind_rewind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
}
void
@@ -178,19 +118,6 @@ scm_dynwind_free (void *mem)
scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
}
-#ifdef GUILE_DEBUG
-SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
- (),
- "Return the current wind chain. The wind chain contains all\n"
- "information required by @code{dynamic-wind} to call its\n"
- "argument thunks when entering/exiting its scope.")
-#define FUNC_NAME s_scm_wind_chain
-{
- return scm_i_dynwinds ();
-}
-#undef FUNC_NAME
-#endif
-
void
scm_swap_bindings (SCM vars, SCM vals)
{
@@ -206,97 +133,8 @@ scm_swap_bindings (SCM vars, SCM vals)
}
void
-scm_dowinds (SCM to, long delta)
-{
- scm_i_dowinds (to, delta, NULL, NULL);
-}
-
-void
-scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
-{
- tail:
- if (scm_is_eq (to, scm_i_dynwinds ()))
- {
- if (turn_func)
- turn_func (data);
- }
- else if (delta < 0)
- {
- SCM wind_elt;
-
- scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
- wind_elt = SCM_CAR (to);
-
- if (FRAME_P (wind_elt))
- {
- if (!FRAME_REWINDABLE_P (wind_elt))
- scm_misc_error ("dowinds",
- "cannot invoke continuation from this context",
- SCM_EOL);
- }
- else if (WINDER_P (wind_elt))
- {
- if (WINDER_REWIND_P (wind_elt))
- WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
- }
- else if (SCM_WITH_FLUIDS_P (wind_elt))
- {
- scm_i_swap_with_fluids (wind_elt,
- SCM_I_CURRENT_THREAD->dynamic_state);
- }
- else if (SCM_PROMPT_P (wind_elt))
- ; /* pass -- see vm_reinstate_partial_continuation */
- else if (scm_is_pair (wind_elt))
- scm_call_0 (SCM_CAR (wind_elt));
- else
- /* trash on the wind list */
- abort ();
-
- scm_i_set_dynwinds (to);
- }
- else
- {
- SCM wind;
- SCM wind_elt;
-
- wind = scm_i_dynwinds ();
- wind_elt = SCM_CAR (wind);
- scm_i_set_dynwinds (SCM_CDR (wind));
-
- if (FRAME_P (wind_elt))
- {
- /* Nothing to do. */
- }
- else if (WINDER_P (wind_elt))
- {
- if (!WINDER_REWIND_P (wind_elt))
- WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
- }
- else if (SCM_WITH_FLUIDS_P (wind_elt))
- {
- scm_i_swap_with_fluids (wind_elt,
- SCM_I_CURRENT_THREAD->dynamic_state);
- }
- else if (SCM_PROMPT_P (wind_elt))
- ; /* pass -- though we could invalidate the prompt */
- else if (scm_is_pair (wind_elt))
- scm_call_0 (SCM_CDR (wind_elt));
- else
- /* trash on the wind list */
- abort ();
-
- delta--;
- goto tail; /* scm_dowinds(to, delta-1); */
- }
-}
-
-void
scm_init_dynwind ()
{
- tc16_frame = scm_make_smob_type ("frame", 0);
-
- tc16_winder = scm_make_smob_type ("winder", 0);
-
#include "libguile/dynwind.x"
}
diff --git a/libguile/dynwind.h b/libguile/dynwind.h
index 6e952c4db..9ade05c0b 100644
--- a/libguile/dynwind.h
+++ b/libguile/dynwind.h
@@ -3,7 +3,7 @@
#ifndef SCM_DYNWIND_H
#define SCM_DYNWIND_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008, 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
@@ -24,25 +24,22 @@
#include "libguile/__scm.h"
+#include "libguile/dynstack.h"
-typedef void (*scm_t_guard) (void *);
-
SCM_API SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3);
-SCM_API void scm_dowinds (SCM to, long delta);
-SCM_INTERNAL void scm_i_dowinds (SCM to, long delta,
- void (*turn_func) (void *), void *data);
+
SCM_INTERNAL void scm_init_dynwind (void);
SCM_API void scm_swap_bindings (SCM vars, SCM vals);
typedef enum {
- SCM_F_DYNWIND_REWINDABLE = (1 << 0)
+ SCM_F_DYNWIND_REWINDABLE = SCM_F_DYNSTACK_FRAME_REWINDABLE
} scm_t_dynwind_flags;
typedef enum {
- SCM_F_WIND_EXPLICITLY = (1 << 0)
+ SCM_F_WIND_EXPLICITLY = SCM_F_DYNSTACK_WINDER_EXPLICIT
} scm_t_wind_flags;
SCM_API void scm_dynwind_begin (scm_t_dynwind_flags);
@@ -60,9 +57,6 @@ SCM_API void scm_dynwind_rewind_handler_with_scm (void (*func) (SCM), SCM data,
SCM_API void scm_dynwind_free (void *mem);
-#ifdef GUILE_DEBUG
-SCM_API SCM scm_wind_chain (void);
-#endif /*GUILE_DEBUG*/
#endif /* SCM_DYNWIND_H */
diff --git a/libguile/eval.c b/libguile/eval.c
index 5a42b1ead..142d20abf 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -266,14 +266,14 @@ eval (SCM x, SCM env)
case SCM_M_DYNWIND:
{
- SCM in, out, res, old_winds;
+ SCM in, out, res;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
in = EVAL1 (CAR (mx), env);
out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
- old_winds = scm_i_dynwinds ();
- scm_i_set_dynwinds (scm_acons (in, out, old_winds));
+ scm_dynstack_push_dynwind (&t->dynstack, in, out);
res = eval (CADR (mx), env);
- scm_i_set_dynwinds (old_winds);
+ scm_dynstack_pop (&t->dynstack);
scm_call_0 (out);
return res;
}
@@ -281,7 +281,9 @@ eval (SCM x, SCM env)
case SCM_M_WITH_FLUIDS:
{
long i, len;
- SCM *fluidv, *valuesv, walk, wf, res;
+ SCM *fluidv, *valuesv, walk, res;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
@@ -290,12 +292,10 @@ eval (SCM x, SCM env)
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
valuesv[i] = EVAL1 (CAR (walk), env);
- wf = scm_i_make_with_fluids (len, fluidv, valuesv);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
+ thread->dynamic_state);
res = eval (CDDR (mx), env);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return res;
}
@@ -437,20 +437,27 @@ eval (SCM x, SCM env)
case SCM_M_PROMPT:
{
- SCM vm, res;
- /* We need the prompt and handler values after a longjmp case,
- so make sure they are volatile. */
- volatile SCM handler, prompt;
-
- vm = scm_the_vm ();
- prompt = scm_c_make_prompt (EVAL1 (CAR (mx), env),
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
- 0, -1, scm_i_dynwinds ());
+ SCM vm, k, res;
+ scm_t_dynstack_prompt_flags flags;
+ scm_t_prompt_registers *regs;
+ /* We need the handler after nonlocal return to the setjmp, so
+ make sure it is volatile. */
+ volatile SCM handler;
+
+ k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
- scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
+ vm = scm_the_vm ();
+
+ /* Push the prompt onto the dynamic stack. */
+ regs = scm_c_make_prompt_registers (SCM_VM_DATA (vm)->fp,
+ SCM_VM_DATA (vm)->sp,
+ SCM_VM_DATA (vm)->ip,
+ -1);
+ flags = SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY;
+ scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
+ flags, k, regs);
- if (SCM_PROMPT_SETJMP (prompt))
+ if (SCM_I_SETJMP (regs->regs))
{
/* The prompt exited nonlocally. */
proc = handler;
@@ -459,7 +466,7 @@ eval (SCM x, SCM env)
}
res = eval (CADR (mx), env);
- scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 282718e65..8e36acde6 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -20,7 +20,6 @@
# include <config.h>
#endif
-#include <alloca.h>
#include <stdio.h>
#include <string.h>
@@ -92,14 +91,6 @@ scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED
scm_putc_unlocked ('>', port);
}
-void
-scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts_unlocked ("#<with-fluids ", port);
- scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc_unlocked ('>', port);
-}
-
/* Return a new fluid. */
static SCM
@@ -310,76 +301,67 @@ apply_thunk (void *thunk)
return scm_call_0 (SCM_PACK (thunk));
}
-SCM
-scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
+size_t
+scm_prepare_fluids (size_t n, SCM *fluids, SCM *values)
{
- SCM ret;
+ size_t j = n;
/* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
but N will usually be small, so perhaps that's OK. */
- {
- size_t i, j = n;
+ while (j--)
+ {
+ size_t i;
+
+ if (SCM_UNLIKELY (!IS_FLUID (fluids[j])))
+ scm_wrong_type_arg ("with-fluids", 0, fluids[j]);
- while (j--)
for (i = 0; i < j; i++)
if (scm_is_eq (fluids[i], fluids[j]))
{
- vals[i] = vals[j]; /* later bindings win */
+ values[i] = values[j]; /* later bindings win */
n--;
break;
}
- }
-
- ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
- SCM_SET_CELL_WORD_1 (ret, n);
-
- while (n--)
- {
- if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
- scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
}
- return ret;
+ return n;
}
void
-scm_i_swap_with_fluids (SCM wf, SCM dynstate)
+scm_swap_fluids (size_t n, SCM *fluids, SCM *values, SCM dynstate)
{
- SCM fluids;
+ SCM fluid_vector;
size_t i, max = 0;
- fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+ fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
/* We could cache the max in the with-fluids, but that would take more mem,
and we're touching all the fluids anyway, so this per-swap traversal should
be OK. */
- for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
+ for (i = 0; i < n; i++)
{
- size_t num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
+ size_t num = FLUID_NUM (fluids[i]);
max = (max > num) ? max : num;
}
- if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector)))
{
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (dynstate);
- fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+ fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
}
/* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
- for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
+ for (i = 0; i < n; i++)
{
size_t fluid_num;
SCM x;
- fluid_num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
- x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
- SCM_SIMPLE_VECTOR_SET (fluids, fluid_num,
- SCM_WITH_FLUIDS_NTH_VAL (wf, i));
- SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
+ fluid_num = FLUID_NUM (fluids[i]);
+ x = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num);
+ SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, values[i]);
+ values[i] = x;
}
}
@@ -400,9 +382,10 @@ SCM
scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluids"
{
- SCM wf, ans;
+ SCM ans;
long flen, vlen, i;
SCM *fluidsv, *valuesv;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
@@ -423,12 +406,10 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
values = SCM_CDR (values);
}
- wf = scm_i_make_with_fluids (flen, fluidsv, valuesv);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ scm_dynstack_push_fluids (&thread->dynstack, flen, fluidsv, valuesv,
+ thread->dynamic_state);
ans = cproc (cdata);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return ans;
}
@@ -449,14 +430,13 @@ SCM
scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluid"
{
- SCM ans, wf;
+ SCM ans;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
- wf = scm_i_make_with_fluids (1, &fluid, &value);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ scm_dynstack_push_fluids (&thread->dynstack, 1, &fluid, &value,
+ thread->dynamic_state);
ans = cproc (cdata);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return ans;
}
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 7d134b922..227877251 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -3,7 +3,7 @@
#ifndef SCM_FLUIDS_H
#define SCM_FLUIDS_H
-/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1996,2000,2001, 2006, 2008, 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
@@ -27,17 +27,6 @@
#include "libguile/root.h"
#include "libguile/vectors.h"
-/* These "with-fluids" objects live on the dynamic stack, and record previous
- values of fluids. Guile uses shallow binding, so the current fluid values are
- always in the same place for a given thread, in the dynamic-state vector.
- */
-
-#define SCM_WITH_FLUIDS_P(x) (SCM_HAS_TYP7 (x, scm_tc7_with_fluids))
-#define SCM_WITH_FLUIDS_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8)
-#define SCM_WITH_FLUIDS_NTH_FLUID(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2))
-#define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
-#define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 + (n)*2, (v)))
-
/* Fluids.
@@ -70,8 +59,9 @@ SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
SCM_API SCM scm_fluid_unset_x (SCM fluid);
SCM_API SCM scm_fluid_bound_p (SCM fluid);
-SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals);
-SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state);
+SCM_INTERNAL size_t scm_prepare_fluids (size_t n, SCM *fluids, SCM *vals);
+SCM_INTERNAL void scm_swap_fluids (size_t n, SCM *fluids, SCM *vals,
+ SCM dynamic_state);
SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
SCM (*cproc)(void *), void *cdata);
@@ -101,7 +91,6 @@ SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void);
SCM_INTERNAL void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate);
-SCM_INTERNAL void scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_fluids (void);
#endif /* SCM_FLUIDS_H */
diff --git a/libguile/print.c b/libguile/print.c
index eb601322e..fd0cc3da9 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -645,12 +645,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_vm_cont:
scm_i_vm_cont_print (exp, port, pstate);
break;
- case scm_tc7_prompt:
- scm_i_prompt_print (exp, port, pstate);
- break;
- case scm_tc7_with_fluids:
- scm_i_with_fluids_print (exp, port, pstate);
- break;
case scm_tc7_array:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_i_print_array (exp, port, pstate);
diff --git a/libguile/root.c b/libguile/root.c
index 8c8fd1aa5..c83da1c3c 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009, 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
@@ -109,12 +109,14 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data,
SCM_STACKITEM *stack_start)
{
struct cwdr_handler_data my_handler_data;
- SCM answer, old_winds;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ SCM answer;
+ scm_t_dynstack *old_dynstack;
/* Exit caller's dynamic state.
*/
- old_winds = scm_i_dynwinds ();
- scm_dowinds (SCM_EOL, scm_ilength (old_winds));
+ old_dynstack = scm_dynstack_capture_all (dynstack);
+ scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack));
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
@@ -128,7 +130,7 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data,
/* Enter caller's dynamic state.
*/
- scm_dowinds (old_winds, - scm_ilength (old_winds));
+ scm_dynstack_wind (dynstack, SCM_DYNSTACK_FIRST (old_dynstack));
/* Now run the real handler iff the body did a throw. */
if (my_handler_data.run_handler)
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 9599554a2..610a36e24 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -1,5 +1,5 @@
/* A stack holds a frame chain
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -95,19 +95,17 @@ stack_depth (SCM frame)
* encountered.
*/
-static SCM
+static SCM*
find_prompt (SCM key)
{
- SCM winds;
- for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
- {
- SCM elt = scm_car (winds);
- if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), key))
- return elt;
- }
- scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
- scm_list_1 (key));
- return SCM_BOOL_F; /* not reached */
+ scm_t_prompt_registers *regs;
+
+ if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
+ &regs, NULL))
+ scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
+ scm_list_1 (key));
+
+ return regs->fp;
}
static void
@@ -136,10 +134,9 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
/* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
symbols. */
- SCM prompt = find_prompt (inner_key);
+ SCM *fp = find_prompt (inner_key);
for (; len; len--, frame = scm_frame_previous (frame))
- if (SCM_PROMPT_REGISTERS (prompt)->fp
- == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
break;
}
else
@@ -171,13 +168,12 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
/* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
symbols. */
- SCM prompt = find_prompt (outer_key);
+ SCM *fp = find_prompt (outer_key);
while (len)
{
frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
- if (SCM_PROMPT_REGISTERS (prompt)->fp
- == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
break;
}
}
@@ -257,7 +253,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
SCM cont;
struct scm_vm_cont *c;
- cont = scm_i_vm_capture_continuation (scm_the_vm ());
+ cont = scm_i_capture_current_stack ();
c = SCM_VM_CONT_DATA (cont);
frame = scm_c_make_frame (cont, c->fp + c->reloc,
diff --git a/libguile/tags.h b/libguile/tags.h
index b49e61651..a194ea0be 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -423,8 +423,8 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#define scm_tc7_vm 55
#define scm_tc7_vm_cont 71
-#define scm_tc7_prompt 61
-#define scm_tc7_with_fluids 63
+#define scm_tc7_unused_17 61
+#define scm_tc7_unused_21 63
#define scm_tc7_unused_19 69
#define scm_tc7_program 79
#define scm_tc7_weak_set 85
diff --git a/libguile/threads.c b/libguile/threads.c
index 313557001..f9104f9e3 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -543,7 +543,9 @@ guilify_self_1 (struct GC_stack_base *base)
t.held_mutex = NULL;
t.join_queue = SCM_EOL;
t.dynamic_state = SCM_BOOL_F;
- t.dynwinds = SCM_EOL;
+ t.dynstack.base = NULL;
+ t.dynstack.top = NULL;
+ t.dynstack.limit = NULL;
t.active_asyncs = SCM_EOL;
t.block_asyncs = 1;
t.pending_asyncs = 1;
@@ -617,6 +619,10 @@ guilify_self_2 (SCM parent)
else
t->dynamic_state = scm_i_make_initial_dynamic_state ();
+ t->dynstack.base = scm_gc_malloc (16 * sizeof (scm_t_bits), "dynstack");
+ t->dynstack.limit = t->dynstack.base + 16;
+ t->dynstack.top = t->dynstack.base + SCM_DYNSTACK_HEADER_LEN;
+
t->join_queue = make_queue ();
t->block_asyncs = 0;
}
diff --git a/libguile/threads.h b/libguile/threads.h
index 54d64141b..3030f6fdc 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -3,7 +3,7 @@
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 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
@@ -27,8 +27,8 @@
#include "libguile/procs.h"
#include "libguile/throw.h"
#include "libguile/root.h"
+#include "libguile/dynstack.h"
#include "libguile/iselect.h"
-#include "libguile/dynwind.h"
#include "libguile/continuations.h"
#if SCM_USE_PTHREAD_THREADS
@@ -79,7 +79,9 @@ typedef struct scm_i_thread {
/* Other thread local things.
*/
SCM dynamic_state;
- SCM dynwinds;
+
+ /* The dynamic stack. */
+ scm_t_dynstack dynstack;
/* For system asyncs.
*/
@@ -200,12 +202,8 @@ SCM_INTERNAL SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread;
# endif /* !SCM_HAVE_THREAD_STORAGE_CLASS */
-# define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
-# define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
-
#endif /* BUILDING_LIBGUILE */
-
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_misc_mutex;
/* Convenience functions for working with the pthread API in guile
diff --git a/libguile/throw.c b/libguile/throw.c
index 29ccc8aba..2f5c71225 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 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
@@ -456,7 +456,11 @@ SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");
static SCM
pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
- SCM vm, prompt, res;
+ volatile SCM vm, v_handler;
+ SCM res;
+ scm_t_prompt_registers *regs;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ scm_t_dynstack_prompt_flags flags;
/* Only handle catch-alls without pre-unwind handlers */
if (!SCM_UNBNDP (pre_unwind_handler))
@@ -464,22 +468,29 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
abort ();
+ /* These two are volatile, so we know we can access them after a
+ nonlocal return to the setjmp. */
vm = scm_the_vm ();
- prompt = scm_c_make_prompt (sym_pre_init_catch_tag,
- SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
- SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
+ v_handler = handler;
- if (SCM_PROMPT_SETJMP (prompt))
+ /* Push the prompt onto the dynamic stack. */
+ regs = scm_c_make_prompt_registers (SCM_VM_DATA (vm)->fp,
+ SCM_VM_DATA (vm)->sp,
+ SCM_VM_DATA (vm)->ip,
+ -1);
+ flags = SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY;
+ scm_dynstack_push_prompt (dynstack, flags, sym_pre_init_catch_tag, regs);
+
+ if (SCM_I_SETJMP (regs->regs))
{
/* nonlocal exit */
SCM args = scm_i_prompt_pop_abort_args_x (vm);
/* cdr past the continuation */
- return scm_apply_0 (handler, scm_cdr (args));
+ return scm_apply_0 (v_handler, scm_cdr (args));
}
res = scm_call_0 (thunk);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_pop (dynstack);
return res;
}
@@ -487,14 +498,9 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
static int
find_pre_init_catch (void)
{
- SCM winds;
-
- /* Search the wind list for an appropriate prompt.
- "Waiter, please bring us the wind list." */
- for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
- if (SCM_PROMPT_P (SCM_CAR (winds))
- && scm_is_eq (SCM_PROMPT_TAG (SCM_CAR (winds)), sym_pre_init_catch_tag))
- return 1;
+ if (scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack,
+ sym_pre_init_catch_tag, NULL, NULL))
+ return 1;
return 0;
}
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8981042f8..f30ed9d02 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,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
@@ -1032,25 +1032,49 @@ VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
- SCM vmcont, intwinds, prevwinds;
- POP2 (intwinds, vmcont);
+ SCM vmcont;
+ scm_t_ptrdiff reloc;
+ POP (vmcont);
SYNC_REGISTER ();
if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
{ finish_args = vmcont;
goto vm_error_continuation_not_rewindable;
}
- prevwinds = scm_i_dynwinds ();
- vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
- vm_cookie);
+ reloc = vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp,
+ vm_cookie);
- /* Rewind prompt jmpbuffers, if any. */
+ /* The prompt captured a slice of the dynamic stack. Here we wind
+ those entries onto the current thread's stack.
+
+ Unhappily, this code must be here, in vm_engine, so that the setjmp
+ captures the stack in this function, and so that subsequently wound
+ stack entries don't see stale prompts. */
{
- SCM winds = scm_i_dynwinds ();
- for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
- if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
- break;
+ scm_t_bits *walk;
+
+ for (walk = SCM_DYNSTACK_FIRST (SCM_VM_CONT_DATA (vmcont)->dynstack);
+ SCM_DYNSTACK_TAG (walk);
+ walk = SCM_DYNSTACK_NEXT (walk))
+ {
+ scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+ scm_dynstack_wind_1 (&current_thread->dynstack, walk);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
+ {
+ scm_t_prompt_registers *rewound;
+
+ rewound = scm_dynstack_relocate_prompt (&current_thread->dynstack,
+ reloc, vm_cookie);
+
+ /* Reset the jmpbuf. */
+ if (SCM_I_SETJMP (rewound->regs))
+ /* Non-local exit to this newly rewound prompt. */
+ break;
+ }
+ }
}
-
+
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
@@ -1176,9 +1200,12 @@ VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, vm_cont, cont;
+ scm_t_dynstack *dynstack;
POP (proc);
SYNC_ALL ();
- vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
+ dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
+ vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL,
+ dynstack, 0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
@@ -1211,15 +1238,18 @@ VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
{
int first;
SCM proc, vm_cont, cont;
+ scm_t_dynstack *dynstack;
POP (proc);
SYNC_ALL ();
/* In contrast to call/cc, tail-call/cc captures the continuation without the
stack frame. */
+ dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
vm_cont = scm_i_vm_capture_stack (vp->stack_base,
SCM_FRAME_DYNAMIC_LINK (fp),
SCM_FRAME_LOWER_ADDRESS (fp) - 1,
SCM_FRAME_RETURN_ADDRESS (fp),
SCM_FRAME_MV_RETURN_ADDRESS (fp),
+ dynstack,
0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
@@ -1543,7 +1573,9 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
{
scm_t_int32 offset;
scm_t_uint8 escape_only_p;
- SCM k, prompt;
+ SCM k;
+ scm_t_dynstack_prompt_flags flags;
+ scm_t_prompt_registers *regs;
escape_only_p = FETCH ();
FETCH_OFFSET (offset);
@@ -1551,10 +1583,10 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
SYNC_REGISTER ();
/* Push the prompt onto the dynamic stack. */
- prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
- scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
- if (SCM_PROMPT_SETJMP (prompt))
+ regs = scm_c_make_prompt_registers (fp, sp, ip + offset, vm_cookie);
+ flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
+ scm_dynstack_push_prompt (&current_thread->dynstack, flags, k, regs);
+ if (SCM_I_SETJMP (regs->regs))
{
/* The prompt exited nonlocally. Cache the regs back from the vp, and go
to the handler.
@@ -1595,7 +1627,7 @@ VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
finish_args = unwind;
goto vm_error_not_a_thunk;
}
- scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
+ scm_dynstack_push_dynwind (&current_thread->dynstack, wind, unwind);
NEXT;
}
@@ -1614,32 +1646,28 @@ VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
{
/* A normal exit from the dynamic extent of an expression. Pop the top entry
off of the dynamic stack. */
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_pop (&current_thread->dynstack);
NEXT;
}
VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
{
unsigned n = FETCH ();
- SCM wf;
SYNC_REGISTER ();
sp -= 2 * n;
CHECK_UNDERFLOW ();
- wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
+ scm_dynstack_push_fluids (&current_thread->dynstack, n, sp + 1, sp + 1 + n,
+ current_thread->dynamic_state);
NULLSTACK (2 * n);
-
- scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
NEXT;
}
VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
{
- SCM wf;
- wf = scm_car (scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
- scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
+ /* This function must not allocate. */
+ scm_dynstack_unwind_fluids (&current_thread->dynstack,
+ current_thread->dynamic_state);
NEXT;
}
diff --git a/libguile/vm.c b/libguile/vm.c
index e386202ad..a283857f0 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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
@@ -264,13 +275,14 @@ vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
}
-static void
-vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
+static scm_t_ptrdiff
+vm_reinstate_partial_continuation (SCM vm, SCM cont,
size_t n, SCM *argv, scm_t_int64 vm_cookie)
{
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 +291,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,31 +325,16 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
vp->sp++;
*vp->sp = scm_from_size_t (n);
- /* Finally, rewind the dynamic state.
+ /* Finally, rewind the dynamic state. Unhappily, we have to do this
+ in the vm_engine. If we do it here, the stack frame will likely
+ have been stompled by some future call out of the VM, so we will
+ return to some other part of the VM.
- 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. */
- {
- long delta = 0;
- SCM newwinds = scm_i_dynwinds ();
- for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
- {
- 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_dowinds (newwinds, delta);
- }
+ We used to wind and relocate the prompts here, but that's bogus,
+ because a rewinder would then be able to abort to a prompt with a
+ stale jmpbuf. */
+
+ return reloc;
#undef RELOC
}
diff --git a/libguile/vm.h b/libguile/vm.h
index 2479ee4a4..cf712fdd2 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 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
@@ -93,6 +93,7 @@ struct scm_vm_cont {
scm_t_ptrdiff stack_size;
SCM *stack_base;
scm_t_ptrdiff reloc;
+ scm_t_dynstack *dynstack;
scm_t_uint32 flags;
};
@@ -107,9 +108,10 @@ SCM_INTERNAL SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
scm_print_state *pstate);
-SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
+SCM_INTERNAL SCM scm_i_capture_current_stack (void);
SCM_INTERNAL 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_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
scm_print_state *pstate);