summaryrefslogtreecommitdiff
path: root/libguile/dynstack.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/dynstack.c')
-rw-r--r--libguile/dynstack.c556
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:
+*/