[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-82-g9ede013
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-82-g9ede013 |
|
Date: |
Sat, 03 Mar 2012 16:18:11 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=9ede013f68361df731cadc62844be11d1bfea7e5
The branch, master has been updated
via 9ede013f68361df731cadc62844be11d1bfea7e5 (commit)
via 05b4d9106d301af055d675cd0ffdd3699642a0ee (commit)
from 07e69928fcab0c5a0e1133fc1f66b18ddd09d408 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 9ede013f68361df731cadc62844be11d1bfea7e5
Author: Andy Wingo <address@hidden>
Date: Sat Mar 3 17:01:16 2012 +0100
the dynamic stack is really a stack now, instead of a list
* libguile/dynstack.h:
* libguile/dynstack.c: New files, implementing the dynamic stack as a
true stack instead of a linked list. This lowers the cost of
dynwinds: frames, winders, prompts, with-fluids, and dynamic-wind.
For the most part, we allocate these items directly on the stack.
* libguile/dynwinds.h:
* libguile/dynwinds.c: Adapt all manipulators of the wind stack to use
interfaces from dynstack.c. Remove heap-allocated winder and frame
object types.
(scm_dowinds, scm_i_dowinds): Remove these. The first was exported,
but it was not a public interface.
* libguile/continuations.c:
* libguile/continuations.h (scm_t_contregs): Continuation objects
reference scm_t_dynstack* values now. Adapt to the new interfaces.
* libguile/control.c:
* libguile/control.h: There is no longer a scm_tc7_prompt kind of object
that can be allocated on the heap. Instead, the prompt flags, key,
and registers are pushed on the dynwind stack. (The registers are
still on the heap.) Also, since the vm_cont will reference the
dynwinds, make the partial continuation stub take just one extra arg,
instead of storing the intwinds separately in the object table.
* libguile/fluids.c:
* libguile/fluids.h: No more with-fluids objects; instead, the fluids go
on the dynstack. The values still have to be on the heap, though.
(scm_prepare_fluids, scm_swap_fluids): New internal functions,
replacing scm_i_make_with_fluids and scm_i_swap_with_fluids.
* libguile/print.c: Remove prompt and with-fluids printers.
* libguile/tags.h: Revert prompt and with-fluids tc7 values to what they
were before they were allocated.
* libguile/vm-i-system.c (partial_cont_call): Just pop the vmcont, the
intwinds will not be passed as a second arg. Rewind the dynamic stack
from within the VM, so that any rewinder sees valid prompt entries.
(call_cc, tail_call_cc): Adapt to pass the dynstack to
scm_i_vm_capture_stack.
(prompt, wind, unwind, wind_fluids, unwind_fluids): Adapt to the new
interfaces.
* libguile/vm.h (scm_i_capture_current_stack): Rename from
scm_i_vm_capture_continuation.
(scm_i_vm_capture_stack): Take a dynstack as an argument.
* libguile/vm.c (vm_reinstate_partial_continuation): Don't wind here, as
that could result in winders seeing invalid prompts.
* libguile/eval.c:
* libguile/root.c:
* libguile/stacks.c:
* libguile/threads.c:
* libguile/threads.h:
* libguile/throw.c: Adapt other users of dynwinds to use the dynstack.
commit 05b4d9106d301af055d675cd0ffdd3699642a0ee
Author: Andy Wingo <address@hidden>
Date: Sun Feb 26 23:02:16 2012 +0100
comment formatting in ports.c
* libguile/ports.c: Fix comment.
-----------------------------------------------------------------------
Summary of changes:
libguile/Makefile.am | 2 +
libguile/continuations.c | 41 ++--
libguile/continuations.h | 3 +-
libguile/control.c | 119 ++++------
libguile/control.h | 28 +--
libguile/dynstack.c | 544 ++++++++++++++++++++++++++++++++++++++++++++++
libguile/dynstack.h | 206 +++++++++++++++++
libguile/dynwind.c | 226 +++----------------
libguile/dynwind.h | 16 +-
libguile/eval.c | 55 +++--
libguile/fluids.c | 86 +++-----
libguile/fluids.h | 19 +--
libguile/ports.c | 6 +-
libguile/print.c | 6 -
libguile/root.c | 12 +-
libguile/stacks.c | 34 ++--
libguile/tags.h | 4 +-
libguile/threads.c | 8 +-
libguile/threads.h | 12 +-
libguile/throw.c | 40 ++--
libguile/vm-i-system.c | 86 +++++---
libguile/vm.c | 60 +++---
libguile/vm.h | 6 +-
23 files changed, 1082 insertions(+), 537 deletions(-)
create mode 100644 libguile/dynstack.c
create mode 100644 libguile/dynstack.h
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index df3e9d0..6d2da66 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -133,6 +133,7 @@ address@hidden@_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 058e21e..fe7618f 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 e0a4556..29ea1c1 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 ff6bfd8..613ffbe 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, ®s, &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 ebf255f..a912855 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 0000000..56e007c
--- /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 0000000..33389ca
--- /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 bec2dc8..0579186 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 6e952c4..9ade05c 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 5a42b1e..142d20a 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 282718e..8e36acd 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 7d134b9..2278772 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/ports.c b/libguile/ports.c
index e17ea06..a4651ca 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1588,9 +1588,9 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
}
/* Read an ISO-8859-1 codepoint (a byte) from PORT. On success, return
- *0 and set CODEPOINT to the codepoint that was read, fill BUF with
- *its UTF-8 representation, and set *LEN to the length in bytes.
- *Return `EILSEQ' on error. */
+ 0 and set *CODEPOINT to the codepoint that was read, fill BUF with
+ its UTF-8 representation, and set *LEN to the length in bytes.
+ Return `EILSEQ' on error. */
static int
get_latin1_codepoint (SCM port, scm_t_wchar *codepoint,
char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
diff --git a/libguile/print.c b/libguile/print.c
index eb60132..fd0cc3d 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 8c8fd1a..c83da1c 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 9599554..610a36e 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,
+ ®s, 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 b49e616..a194ea0 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 3135570..f9104f9 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 54d6414..3030f6f 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 29ccc8a..2f5c712 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 8981042..f30ed9d 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 (¤t_thread->dynstack, walk);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
+ {
+ scm_t_prompt_registers *rewound;
+
+ rewound = scm_dynstack_relocate_prompt (¤t_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 (¤t_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 (¤t_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 (¤t_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 (¤t_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 (¤t_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 (¤t_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 (¤t_thread->dynstack,
+ current_thread->dynamic_state);
NEXT;
}
diff --git a/libguile/vm.c b/libguile/vm.c
index e386202..a283857 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 2479ee4..cf712fd 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);
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-82-g9ede013,
Andy Wingo <=