[bpt/guile.git] / libguile / dynstack.c

/* Copyright (C) 2012, 2013 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
 */


\f

#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"


\f

#define PROMPT_WORDS 5
#define PROMPT_KEY(top) (SCM_PACK ((top)[0]))
#define PROMPT_FP(top) ((scm_t_ptrdiff) ((top)[1]))
#define PROMPT_SP(top) ((scm_t_ptrdiff) ((top)[2]))
#define PROMPT_IP(top) ((scm_t_uint32 *) ((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_FLUID_WORDS 2
#define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
#define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))


\f

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
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,
                               WINDER_WORDS);
  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,
                               WINDER_WORDS);
  words[0] = (scm_t_bits) proc;
  words[1] = (scm_t_bits) data;
}

/* The fluid is stored on the stack, but the value has to be stored on the heap,
   so that all continuations that capture this dynamic scope capture the same
   binding.  */
void
scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
                         SCM dynamic_state)
{
  scm_t_bits *words;
  SCM value_box;

  if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)))
    scm_wrong_type_arg ("with-fluid*", 0, fluid);

  value_box = scm_make_variable (value);

  words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUID, 0,
                               WITH_FLUID_WORDS);
  words[0] = SCM_UNPACK (fluid);
  words[1] = SCM_UNPACK (value_box);

  /* Go ahead and swap them.  */
  scm_swap_fluid (fluid, value_box, dynamic_state);
}

void
scm_dynstack_push_prompt (scm_t_dynstack *dynstack,
                          scm_t_dynstack_prompt_flags flags,
                          SCM key,
                          scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
                          scm_t_uint32 *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_offset;
  words[2] = (scm_t_bits) sp_offset;
  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,
                               DYNWIND_WORDS);
  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_FLUID:
      scm_swap_fluid (WITH_FLUID_FLUID (item),
                      WITH_FLUID_VALUE_BOX (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;

  tag = dynstack_pop (dynstack, &words);
  
  type = SCM_DYNSTACK_TAG_TYPE (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_FLUID:
      scm_swap_fluid (WITH_FLUID_FLUID (words),
                      WITH_FLUID_VALUE_BOX (words),
                      SCM_I_CURRENT_THREAD->dynamic_state);
      clear_scm_t_bits (words, WITH_FLUID_WORDS);
      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_t_ptrdiff *fp_offset, scm_t_ptrdiff *sp_offset,
                          scm_t_uint32 **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_offset)
            *fp_offset = PROMPT_FP (walk);
          if (sp_offset)
            *sp_offset = 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_fluid (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_FLUID);
  assert (len == WITH_FLUID_WORDS);

  scm_swap_fluid (WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX (words),
                  dynamic_state);
  clear_scm_t_bits (words, len);
}


/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
98eaef1b	1	/* Copyright (C) 2012, 2013 Free Software Foundation, Inc.
9ede013f AW	2	*
	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public License
	5	* as published by the Free Software Foundation; either version 3 of
	6	* the License, or (at your option) any later version.
	7	*
	8	* This library is distributed in the hope that it will be useful, but
	9	* WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	11	* Lesser General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU Lesser General Public
	14	* License along with this library; if not, write to the Free Software
	15	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
	16	* 02110-1301 USA
	17	*/
	18
	19
	20	\f
	21
	22	#ifdef HAVE_CONFIG_H
	23	# include <config.h>
	24	#endif
	25
	26	#include <assert.h>
	27
	28	#include "libguile/_scm.h"
	29	#include "libguile/control.h"
	30	#include "libguile/eval.h"
	31	#include "libguile/fluids.h"
	32	#include "libguile/dynstack.h"
	33
	34
	35	\f
	36
9d381ba4	37	#define PROMPT_WORDS 5
9ede013f	38	#define PROMPT_KEY(top) (SCM_PACK ((top)[0]))
0bca90aa AW	39	#define PROMPT_FP(top) ((scm_t_ptrdiff) ((top)[1]))
0bca90aa AW	40	#define PROMPT_SP(top) ((scm_t_ptrdiff) ((top)[2]))
9121d9f1	41	#define PROMPT_IP(top) ((scm_t_uint32 *) ((top)[3]))
9d381ba4	42	#define PROMPT_JMPBUF(top) ((scm_i_jmp_buf *) ((top)[4]))
9ede013f AW	43
	44	#define WINDER_WORDS 2
	45	#define WINDER_PROC(top) ((scm_t_guard) ((top)[0]))
	46	#define WINDER_DATA(top) ((void *) ((top)[1]))
	47
	48	#define DYNWIND_WORDS 2
	49	#define DYNWIND_ENTER(top) (SCM_PACK ((top)[0]))
	50	#define DYNWIND_LEAVE(top) (SCM_PACK ((top)[1]))
	51
98eaef1b AW	52	#define WITH_FLUID_WORDS 2
	53	#define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
	54	#define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
9ede013f AW	55
	56
	57	\f
	58
	59	static void
	60	copy_scm_t_bits (scm_t_bits dst, scm_t_bits src, size_t n)
	61	{
	62	size_t i;
	63
	64	for (i = 0; i < n; i++)
	65	dst[i] = src[i];
	66	}
	67
9ede013f AW	68	static void
	69	clear_scm_t_bits (scm_t_bits *items, size_t n)
	70	{
	71	size_t i;
	72
	73	for (i = 0; i < n; i++)
	74	items[i] = 0;
	75	}
	76
	77	/* Ensure space for N additional words. */
	78	static void
	79	dynstack_ensure_space (scm_t_dynstack *dynstack, size_t n)
	80	{
	81	size_t capacity = SCM_DYNSTACK_CAPACITY (dynstack);
	82	size_t height = SCM_DYNSTACK_HEIGHT (dynstack);
	83
	84	n += SCM_DYNSTACK_HEADER_LEN;
	85
	86	if (capacity < height + n)
	87	{
	88	scm_t_bits *new_base;
	89
	90	while (capacity < height + n)
	91	capacity = (capacity < 4) ? 8 : (capacity * 2);
	92
	93	new_base = scm_gc_malloc (capacity * sizeof(scm_t_bits), "dynstack");
	94
	95	copy_scm_t_bits (new_base, dynstack->base, height);
	96	clear_scm_t_bits (dynstack->base, height);
	97
	98	dynstack->base = new_base;
	99	dynstack->top = new_base + height;
	100	dynstack->limit = new_base + capacity;
	101	}
	102	}
	103
	104	static inline scm_t_bits *
	105	push_dynstack_entry_unchecked (scm_t_dynstack *dynstack,
	106	scm_t_dynstack_item_type type,
	107	scm_t_bits flags, size_t len)
	108	{
	109	scm_t_bits *ret = dynstack->top;
	110
	111	SCM_DYNSTACK_SET_TAG (dynstack->top, SCM_MAKE_DYNSTACK_TAG (type, flags, len));
	112	dynstack->top += SCM_DYNSTACK_HEADER_LEN + len;
	113	SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, SCM_DYNSTACK_HEADER_LEN + len);
	114
	115	return ret;
	116	}
	117
	118	static inline scm_t_bits *
	119	push_dynstack_entry (scm_t_dynstack *dynstack,
	120	scm_t_dynstack_item_type type,
	121	scm_t_bits flags, size_t len)
	122	{
	123	if (SCM_UNLIKELY (!SCM_DYNSTACK_HAS_SPACE (dynstack, len)))
	124	dynstack_ensure_space (dynstack, len);
	125	return push_dynstack_entry_unchecked (dynstack, type, flags, len);
	126	}
	127
	128	void
	129	scm_dynstack_push_frame (scm_t_dynstack *dynstack,
	130	scm_t_dynstack_frame_flags flags)
	131	{
132	push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_FRAME, flags, 0);
133	}
134
135	void
136	scm_dynstack_push_rewinder (scm_t_dynstack *dynstack,
137	scm_t_dynstack_winder_flags flags,
138	scm_t_guard proc, void *data)
139	{
140	scm_t_bits *words;
141
98eaef1b AW	142	words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_REWINDER, flags,
98eaef1b AW	143	WINDER_WORDS);
9ede013f AW	144	words[0] = (scm_t_bits) proc;
	145	words[1] = (scm_t_bits) data;
	146	}
	147
	148	void
	149	scm_dynstack_push_unwinder (scm_t_dynstack *dynstack,
	150	scm_t_dynstack_winder_flags flags,
	151	scm_t_guard proc, void *data)
	152	{
	153	scm_t_bits *words;
	154
98eaef1b AW	155	words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_UNWINDER, flags,
98eaef1b AW	156	WINDER_WORDS);
9ede013f AW	157	words[0] = (scm_t_bits) proc;
	158	words[1] = (scm_t_bits) data;
	159	}
	160
98eaef1b AW	161	/* The fluid is stored on the stack, but the value has to be stored on the heap,
	162	so that all continuations that capture this dynamic scope capture the same
	163	binding. */
9ede013f	164	void
98eaef1b AW	165	scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
98eaef1b AW	166	SCM dynamic_state)
9ede013f AW	167	{
9ede013f AW	168	scm_t_bits *words;
98eaef1b AW	169	SCM value_box;
	170
	171	if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)))
	172	scm_wrong_type_arg ("with-fluid*", 0, fluid);
9ede013f	173
98eaef1b	174	value_box = scm_make_variable (value);
9ede013f	175
98eaef1b AW	176	words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUID, 0,
	177	WITH_FLUID_WORDS);
	178	words[0] = SCM_UNPACK (fluid);
	179	words[1] = SCM_UNPACK (value_box);
9ede013f AW	180
9ede013f AW	181	/* Go ahead and swap them. */
98eaef1b	182	scm_swap_fluid (fluid, value_box, dynamic_state);
9ede013f AW	183	}
	184
	185	void
	186	scm_dynstack_push_prompt (scm_t_dynstack *dynstack,
	187	scm_t_dynstack_prompt_flags flags,
9d381ba4	188	SCM key,
0bca90aa AW	189	scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
0bca90aa AW	190	scm_t_uint32 ip, scm_i_jmp_buf registers)
9ede013f AW	191	{
	192	scm_t_bits *words;
	193
9d381ba4 AW	194	words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_PROMPT, flags,
9d381ba4 AW	195	PROMPT_WORDS);
9ede013f	196	words[0] = SCM_UNPACK (key);
0bca90aa AW	197	words[1] = (scm_t_bits) fp_offset;
0bca90aa AW	198	words[2] = (scm_t_bits) sp_offset;
9d381ba4 AW	199	words[3] = (scm_t_bits) ip;
9d381ba4 AW	200	words[4] = (scm_t_bits) registers;
9ede013f AW	201	}
	202
	203	void
	204	scm_dynstack_push_dynwind (scm_t_dynstack *dynstack, SCM enter, SCM leave)
	205	{
	206	scm_t_bits *words;
	207
98eaef1b AW	208	words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNWIND, 0,
98eaef1b AW	209	DYNWIND_WORDS);
9ede013f AW	210	words[0] = SCM_UNPACK (enter);
	211	words[1] = SCM_UNPACK (leave);
	212	}
	213
	214	static inline scm_t_bits
	215	dynstack_pop (scm_t_dynstack dynstack, scm_t_bits *words)
	216	{
	217	scm_t_bits *prev = SCM_DYNSTACK_PREV (dynstack->top);
	218	scm_t_bits tag;
	219
	220	if (SCM_UNLIKELY (!prev))
	221	abort ();
	222
	223	SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, 0);
	224	dynstack->top = prev;
	225
	226	tag = SCM_DYNSTACK_TAG (dynstack->top);
	227	SCM_DYNSTACK_SET_TAG (dynstack->top, 0);
	228	*words = dynstack->top;
	229
	230	return tag;
	231	}
	232
	233	void
	234	scm_dynstack_pop (scm_t_dynstack *dynstack)
	235	{
	236	scm_t_bits tag, *words;
	237	tag = dynstack_pop (dynstack, &words);
	238	clear_scm_t_bits (words, SCM_DYNSTACK_TAG_LEN (tag));
	239	}
	240
	241	scm_t_dynstack *
	242	scm_dynstack_capture_all (scm_t_dynstack *dynstack)
	243	{
	244	return scm_dynstack_capture (dynstack, SCM_DYNSTACK_FIRST (dynstack));
	245	}
	246
	247	scm_t_dynstack *
	248	scm_dynstack_capture (scm_t_dynstack dynstack, scm_t_bits item)
	249	{
	250	char *mem;
	251	scm_t_dynstack *ret;
	252	size_t len;
	253
	254	assert (item >= SCM_DYNSTACK_FIRST (dynstack));
	255	assert (item <= dynstack->top);
	256
	257	len = dynstack->top - item + SCM_DYNSTACK_HEADER_LEN;
	258	mem = scm_gc_malloc (sizeof (ret) + len sizeof(scm_t_bits), "dynstack");
	259	ret = (scm_t_dynstack *) mem;
	260	ret->base = (scm_t_bits ) (mem + sizeof (ret));
	261	ret->limit = ret->base + len;
	262	ret->top = ret->base + len;
	263
	264	copy_scm_t_bits (ret->base, item - SCM_DYNSTACK_HEADER_LEN, len);
	265	SCM_DYNSTACK_SET_PREV_OFFSET (SCM_DYNSTACK_FIRST (ret), 0);
	266
	267	return ret;
	268	}
	269
	270	void
	271	scm_dynstack_wind_1 (scm_t_dynstack dynstack, scm_t_bits item)
	272	{
	273	scm_t_bits tag = SCM_DYNSTACK_TAG (item);
274	scm_t_dynstack_item_type type = SCM_DYNSTACK_TAG_TYPE (tag);
275	scm_t_bits flags = SCM_DYNSTACK_TAG_FLAGS (tag);
276	size_t len = SCM_DYNSTACK_TAG_LEN (tag);
277
278	switch (type)
279	{
280	case SCM_DYNSTACK_TYPE_FRAME:
281	if (!(flags & SCM_F_DYNSTACK_FRAME_REWINDABLE))
282	scm_misc_error ("scm_dynstack_wind_1",
283	"cannot invoke continuation from this context",
284	SCM_EOL);
285	break;
286
287	case SCM_DYNSTACK_TYPE_UNWINDER:
288	break;
289
290	case SCM_DYNSTACK_TYPE_REWINDER:
291	WINDER_PROC (item) (WINDER_DATA (item));
292	break;
293
98eaef1b AW	294	case SCM_DYNSTACK_TYPE_WITH_FLUID:
	295	scm_swap_fluid (WITH_FLUID_FLUID (item),
	296	WITH_FLUID_VALUE_BOX (item),
	297	SCM_I_CURRENT_THREAD->dynamic_state);
9ede013f AW	298	break;
	299
	300	case SCM_DYNSTACK_TYPE_PROMPT:
	301	/* see vm_reinstate_partial_continuation */
	302	break;
	303
	304	case SCM_DYNSTACK_TYPE_DYNWIND:
	305	scm_call_0 (DYNWIND_ENTER (item));
	306	break;
	307
	308	case SCM_DYNSTACK_TYPE_NONE:
	309	default:
	310	abort ();
	311	}
	312
	313	{
	314	scm_t_bits *words = push_dynstack_entry (dynstack, type, flags, len);
	315
	316	copy_scm_t_bits (words, item, len);
	317	}
	318	}
	319
	320	scm_t_bits
	321	scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
	322	{
	323	scm_t_bits tag;
	324	scm_t_bits *words;
	325	scm_t_dynstack_item_type type;
9ede013f AW	326
	327	tag = dynstack_pop (dynstack, &words);
	328
	329	type = SCM_DYNSTACK_TAG_TYPE (tag);
9ede013f AW	330
	331	switch (type)
	332	{
	333	case SCM_DYNSTACK_TYPE_FRAME:
	334	break;
	335
	336	case SCM_DYNSTACK_TYPE_UNWINDER:
	337	WINDER_PROC (words) (WINDER_DATA (words));
	338	clear_scm_t_bits (words, WINDER_WORDS);
	339	break;
	340
	341	case SCM_DYNSTACK_TYPE_REWINDER:
	342	clear_scm_t_bits (words, WINDER_WORDS);
	343	break;
	344
98eaef1b AW	345	case SCM_DYNSTACK_TYPE_WITH_FLUID:
	346	scm_swap_fluid (WITH_FLUID_FLUID (words),
	347	WITH_FLUID_VALUE_BOX (words),
	348	SCM_I_CURRENT_THREAD->dynamic_state);
	349	clear_scm_t_bits (words, WITH_FLUID_WORDS);
9ede013f AW	350	break;
	351
	352	case SCM_DYNSTACK_TYPE_PROMPT:
	353	/* we could invalidate the prompt */
	354	clear_scm_t_bits (words, PROMPT_WORDS);
	355	break;
	356
	357	case SCM_DYNSTACK_TYPE_DYNWIND:
	358	{
	359	SCM proc = DYNWIND_LEAVE (words);
	360	clear_scm_t_bits (words, DYNWIND_WORDS);
	361	scm_call_0 (proc);
	362	}
	363	break;
	364
	365	case SCM_DYNSTACK_TYPE_NONE:
	366	default:
	367	abort ();
	368	}
	369
	370	return tag;
	371	}
	372
	373	void
	374	scm_dynstack_wind (scm_t_dynstack dynstack, scm_t_bits item)
	375	{
	376	for (; SCM_DYNSTACK_TAG (item); item = SCM_DYNSTACK_NEXT (item))
	377	scm_dynstack_wind_1 (dynstack, item);
	378	}
	379
	380	void
	381	scm_dynstack_unwind (scm_t_dynstack dynstack, scm_t_bits base)
	382	{
	383	while (dynstack->top > base)
	384	scm_dynstack_unwind_1 (dynstack);
	385	}
	386
	387	static int
	388	same_entries (scm_t_bits walk_a, scm_t_bits next_a,
	389	scm_t_bits walk_b, scm_t_bits next_b)
	390	{
	391	if (SCM_DYNSTACK_TAG (walk_a) != SCM_DYNSTACK_TAG (walk_b))
	392	return 0;
	393
	394	if (next_a - walk_a != next_b - walk_b)
	395	return 0;
	396
	397	assert (SCM_DYNSTACK_PREV_OFFSET (next_a) == next_a - walk_a);
	398	assert (SCM_DYNSTACK_PREV_OFFSET (next_b) == next_b - walk_b);
	399
	400	while (walk_a != next_a)
	401	if ((walk_a++) != (walk_b++))
	402	return 0;
	403
	404	return 1;
	405	}
	406
	407	static ptrdiff_t
	408	shared_prefix_length (scm_t_dynstack a, scm_t_dynstack b)
	409	{
	410	scm_t_bits walk_a, next_a, walk_b, next_b;
	411
	412	walk_a = SCM_DYNSTACK_FIRST (a);
	413	walk_b = SCM_DYNSTACK_FIRST (b);
414
415	next_a = SCM_DYNSTACK_NEXT (walk_a);
416	next_b = SCM_DYNSTACK_NEXT (walk_b);
417
418	while (next_a && next_b && same_entries (walk_a, next_a, walk_b, next_b))
419	{
420	walk_a = next_a;
421	walk_b = next_b;
422
423	next_a = SCM_DYNSTACK_NEXT (walk_a);
424	next_b = SCM_DYNSTACK_NEXT (walk_b);
425	}
426
427	return walk_a - a->base;
428	}
429
430	scm_t_bits *
431	scm_dynstack_unwind_fork (scm_t_dynstack dynstack, scm_t_dynstack branch)
432	{
433	ptrdiff_t join_height;
434
435	join_height = shared_prefix_length (dynstack, branch);
436
437	scm_dynstack_unwind (dynstack, dynstack->base + join_height);
438
439	return branch->base + join_height;
440	}
441
442	scm_t_bits*
443	scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key,
9d381ba4	444	scm_t_dynstack_prompt_flags *flags,
0bca90aa AW	445	scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
0bca90aa AW	446	scm_t_uint32 ip, scm_i_jmp_buf registers)
9ede013f AW	447	{
	448	scm_t_bits *walk;
	449
	450	for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk;
	451	walk = SCM_DYNSTACK_PREV (walk))
	452	{
	453	scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
	454
	455	if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT
	456	&& scm_is_eq (PROMPT_KEY (walk), key))
	457	{
9ede013f AW	458	if (flags)
9ede013f AW	459	*flags = SCM_DYNSTACK_TAG_FLAGS (tag);
0bca90aa AW	460	if (fp_offset)
	461	*fp_offset = PROMPT_FP (walk);
	462	if (sp_offset)
	463	*sp_offset = PROMPT_SP (walk);
9d381ba4 AW	464	if (ip)
	465	*ip = PROMPT_IP (walk);
	466	if (registers)
	467	*registers = PROMPT_JMPBUF (walk);
9ede013f AW	468	return walk;
	469	}
	470	}
	471
	472	return NULL;
	473	}
	474
9d381ba4 AW	475	void
	476	scm_dynstack_wind_prompt (scm_t_dynstack dynstack, scm_t_bits item,
	477	scm_t_ptrdiff reloc, scm_i_jmp_buf *registers)
9ede013f	478	{
9d381ba4	479	scm_t_bits tag = SCM_DYNSTACK_TAG (item);
9ede013f	480
9d381ba4	481	if (SCM_DYNSTACK_TAG_TYPE (tag) != SCM_DYNSTACK_TYPE_PROMPT)
9ede013f AW	482	abort ();
9ede013f AW	483
9d381ba4 AW	484	scm_dynstack_push_prompt (dynstack,
	485	SCM_DYNSTACK_TAG_FLAGS (tag),
	486	PROMPT_KEY (item),
	487	PROMPT_FP (item) + reloc,
	488	PROMPT_SP (item) + reloc,
	489	PROMPT_IP (item),
	490	registers);
9ede013f AW	491	}
	492
	493	void
	494	scm_dynstack_unwind_frame (scm_t_dynstack *dynstack)
	495	{
	496	/* Unwind up to and including the next frame entry. */
	497	while (1)
	498	{
	499	scm_t_bits tag, *words;
	500
	501	tag = dynstack_pop (dynstack, &words);
	502
	503	switch (SCM_DYNSTACK_TAG_TYPE (tag))
	504	{
	505	case SCM_DYNSTACK_TYPE_FRAME:
	506	return;
	507	case SCM_DYNSTACK_TYPE_REWINDER:
	508	clear_scm_t_bits (words, WINDER_WORDS);
	509	continue;
	510	case SCM_DYNSTACK_TYPE_UNWINDER:
	511	{
	512	scm_t_guard proc = WINDER_PROC (words);
	513	void *data = WINDER_DATA (words);
	514	clear_scm_t_bits (words, WINDER_WORDS);
	515	if (SCM_DYNSTACK_TAG_FLAGS (tag) & SCM_F_DYNSTACK_WINDER_EXPLICIT)
	516	proc (data);
	517	continue;
	518	}
	519	default:
	520	/* We should only see winders. */
	521	abort ();
	522	}
	523	}
	524	}
	525
	526	/* This function must not allocate. */
	527	void
98eaef1b	528	scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, SCM dynamic_state)
9ede013f AW	529	{
	530	scm_t_bits tag, *words;
	531	size_t len;
	532
	533	tag = dynstack_pop (dynstack, &words);
	534	len = SCM_DYNSTACK_TAG_LEN (tag);
	535
98eaef1b AW	536	assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_WITH_FLUID);
98eaef1b AW	537	assert (len == WITH_FLUID_WORDS);
9ede013f	538
98eaef1b AW	539	scm_swap_fluid (WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX (words),
98eaef1b AW	540	dynamic_state);
9ede013f AW	541	clear_scm_t_bits (words, len);
	542	}
	543
	544
	545	/*
	546	Local Variables:
	547	c-file-style: "gnu"
	548	End:
	549	*/