diff options
Diffstat (limited to 'libguile/dynstack.c')
-rw-r--r-- | libguile/dynstack.c | 556 |
1 files changed, 556 insertions, 0 deletions
diff --git a/libguile/dynstack.c b/libguile/dynstack.c new file mode 100644 index 000000000..ce9a2feae --- /dev/null +++ b/libguile/dynstack.c @@ -0,0 +1,556 @@ +/* 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 5 +#define PROMPT_KEY(top) (SCM_PACK ((top)[0])) +#define PROMPT_FP(top) ((SCM *) ((top)[1])) +#define PROMPT_SP(top) ((SCM *) ((top)[2])) +#define PROMPT_IP(top) ((scm_t_uint8 *) ((top)[3])) +#define PROMPT_JMPBUF(top) ((scm_i_jmp_buf *) ((top)[4])) + +#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 *fp, SCM *sp, scm_t_uint8 *ip, + scm_i_jmp_buf *registers) +{ + scm_t_bits *words; + + words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_PROMPT, flags, + PROMPT_WORDS); + words[0] = SCM_UNPACK (key); + words[1] = (scm_t_bits) fp; + words[2] = (scm_t_bits) sp; + words[3] = (scm_t_bits) ip; + words[4] = (scm_t_bits) registers; +} + +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_dynstack_prompt_flags *flags, + SCM **fp, SCM **sp, scm_t_uint8 **ip, + scm_i_jmp_buf **registers) +{ + 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 (flags) + *flags = SCM_DYNSTACK_TAG_FLAGS (tag); + if (fp) + *fp = PROMPT_FP (walk); + if (sp) + *sp = PROMPT_SP (walk); + if (ip) + *ip = PROMPT_IP (walk); + if (registers) + *registers = PROMPT_JMPBUF (walk); + return walk; + } + } + + return NULL; +} + +void +scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item, + scm_t_ptrdiff reloc, scm_i_jmp_buf *registers) +{ + scm_t_bits tag = SCM_DYNSTACK_TAG (item); + + if (SCM_DYNSTACK_TAG_TYPE (tag) != SCM_DYNSTACK_TYPE_PROMPT) + abort (); + + scm_dynstack_push_prompt (dynstack, + SCM_DYNSTACK_TAG_FLAGS (tag), + PROMPT_KEY (item), + PROMPT_FP (item) + reloc, + PROMPT_SP (item) + reloc, + PROMPT_IP (item), + registers); +} + +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: +*/ |