diff options
-rw-r--r-- | libguile/Makefile.am | 2 | ||||
-rw-r--r-- | libguile/continuations.c | 41 | ||||
-rw-r--r-- | libguile/continuations.h | 3 | ||||
-rw-r--r-- | libguile/control.c | 119 | ||||
-rw-r--r-- | libguile/control.h | 28 | ||||
-rw-r--r-- | libguile/dynstack.c | 544 | ||||
-rw-r--r-- | libguile/dynstack.h | 206 | ||||
-rw-r--r-- | libguile/dynwind.c | 226 | ||||
-rw-r--r-- | libguile/dynwind.h | 16 | ||||
-rw-r--r-- | libguile/eval.c | 55 | ||||
-rw-r--r-- | libguile/fluids.c | 86 | ||||
-rw-r--r-- | libguile/fluids.h | 19 | ||||
-rw-r--r-- | libguile/print.c | 6 | ||||
-rw-r--r-- | libguile/root.c | 12 | ||||
-rw-r--r-- | libguile/stacks.c | 34 | ||||
-rw-r--r-- | libguile/tags.h | 4 | ||||
-rw-r--r-- | libguile/threads.c | 8 | ||||
-rw-r--r-- | libguile/threads.h | 12 | ||||
-rw-r--r-- | libguile/throw.c | 40 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 86 | ||||
-rw-r--r-- | libguile/vm.c | 60 | ||||
-rw-r--r-- | libguile/vm.h | 6 |
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, ®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 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, + ®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 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 (¤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 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); |