#include "libguile/smob.h"
#include "libguile/ports.h"
#include "libguile/dynwind.h"
-#include "libguile/values.h"
#include "libguile/eval.h"
#include "libguile/vm.h"
#include "libguile/instructions.h"
(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_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value)
#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
}
/* this may return more than once: the first time with the escape
- procedure, then subsequently with the value to be passed to the
- continuation. */
+ procedure, then subsequently with SCM_UNDEFINED (the vals already having been
+ placed on the VM stack). */
#define FUNC_NAME "scm_i_make_continuation"
SCM
scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
"continuation");
continuation->num_stack_items = stack_size;
continuation->dynenv = scm_i_dynwinds ();
- continuation->throw_value = SCM_EOL;
continuation->root = thread->continuation_root;
src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
return make_continuation_trampoline (cont);
}
else
- {
- SCM ret = continuation->throw_value;
- continuation->throw_value = SCM_BOOL_F;
- return ret;
- }
+ return SCM_UNDEFINED;
}
#undef FUNC_NAME
return scm_c_make_frame (cont->vm_cont,
data->fp + data->reloc,
data->sp + data->reloc,
- data->ip,
+ data->ra,
data->reloc);
}
else
return SCM_BOOL_F;
}
+SCM
+scm_i_contregs_vm (SCM contregs)
+{
+ return SCM_CONTREGS (contregs)->vm;
+}
+
+SCM
+scm_i_contregs_vm_cont (SCM contregs)
+{
+ return SCM_CONTREGS (contregs)->vm_cont;
+}
+
/* {Apply}
*/
* with their correct stack.
*/
-static void scm_dynthrow (SCM, SCM);
+static void scm_dynthrow (SCM);
/* Grow the stack by a fixed amount to provide space to copy in the
* continuation. Possibly this function has to be called several times
scm_t_bits scm_i_dummy;
static void
-grow_stack (SCM cont, SCM val)
+grow_stack (SCM cont)
{
scm_t_bits growth[100];
scm_i_dummy = (scm_t_bits) growth;
- scm_dynthrow (cont, val);
+ scm_dynthrow (cont);
}
copy_stack_data *d = (copy_stack_data *)data;
memcpy (d->dst, d->continuation->stack,
sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
- scm_i_vm_reinstate_continuation (d->continuation->vm,
- d->continuation->vm_cont);
#ifdef __ia64__
SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
#endif
}
static void
-copy_stack_and_call (scm_t_contregs *continuation, SCM val,
+copy_stack_and_call (scm_t_contregs *continuation,
SCM_STACKITEM * dst)
{
long delta;
data.dst = dst;
scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
- continuation->throw_value = val;
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
* actual copying and continuation calling.
*/
static void
-scm_dynthrow (SCM cont, SCM val)
+scm_dynthrow (SCM cont)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
#if SCM_STACK_GROWS_UP
if (dst + continuation->num_stack_items >= &stack_top_element)
- grow_stack (cont, val);
+ grow_stack (cont);
#else
dst -= continuation->num_stack_items;
if (dst <= &stack_top_element)
- grow_stack (cont, val);
+ grow_stack (cont);
#endif /* def SCM_STACK_GROWS_UP */
SCM_FLUSH_REGISTER_WINDOWS;
- copy_stack_and_call (continuation, val, dst);
+ copy_stack_and_call (continuation, dst);
}
void
-scm_i_continuation_call (SCM cont, size_t n, SCM *argv)
+scm_i_check_continuation (SCM cont)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
- SCM args = SCM_EOL;
-
- /* FIXME: shuffle args on VM stack instead of heap-allocating */
- while (n--)
- args = scm_cons (argv[n], args);
if (continuation->root != thread->continuation_root)
scm_misc_error
("%continuation-call",
"invoking continuation would cross continuation barrier: ~A",
scm_list_1 (cont));
-
- scm_dynthrow (cont, scm_values (args));
+}
+
+void
+scm_i_reinstate_continuation (SCM cont)
+{
+ scm_dynthrow (cont);
}
SCM
typedef struct
{
- SCM throw_value;
scm_i_jmp_buf jmpbuf;
SCM dynenv;
#ifdef __ia64__
\f
SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm, SCM vm_cont);
+SCM_INTERNAL void scm_i_check_continuation (SCM cont);
+SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
+
SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
+
SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
-SCM_INTERNAL void scm_i_continuation_call (SCM cont, size_t n, SCM *argv);
+SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
+SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
SCM_API SCM scm_with_continuation_barrier (SCM proc);
c = SCM_VM_CONT_DATA (cont);
frame = scm_c_make_frame (cont, c->fp + c->reloc,
- c->sp + c->reloc, c->ip,
+ c->sp + c->reloc, c->ra,
c->reloc);
}
else if (SCM_VM_FRAME_P (obj))
{
SCM contregs;
POP (contregs);
- scm_i_continuation_call (contregs, sp - (fp - 1), fp);
+
+ scm_i_check_continuation (contregs);
+ vm_return_to_continuation (scm_i_contregs_vm (contregs),
+ scm_i_contregs_vm_cont (contregs),
+ sp - (fp - 1), fp);
+ scm_i_reinstate_continuation (contregs);
+
/* no NEXT */
abort ();
}
VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
{
int first;
- SCM proc, cont;
+ SCM proc, vm_cont, cont;
POP (proc);
SYNC_ALL ();
- cont = scm_i_make_continuation (&first, vm, capture_vm_cont (vp));
+ vm_cont = vm_capture_continuation (vp->stack_base, fp, sp, ip, NULL);
+ cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
PUSH ((SCM)fp); /* dynamic link */
nargs = 1;
goto vm_call;
}
- ASSERT (sp == vp->sp);
- ASSERT (fp == vp->fp);
- else if (SCM_VALUESP (cont))
+ else
{
- /* multiple values returned to continuation */
- SCM values;
- values = scm_struct_ref (cont, SCM_INUM0);
- if (scm_is_null (values))
- goto vm_error_no_values;
- /* non-tail context does not accept multiple values? */
- PUSH (SCM_CAR (values));
- NEXT;
- }
- else
- {
- PUSH (cont);
+ /* otherwise, the vm continuation was reinstated, and
+ scm_i_vm_return_to_continuation pushed on one value. So pull our regs
+ back down from the vp, and march on to the next instruction. */
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
NEXT;
}
}
VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1)
{
int first;
- SCM proc, cont;
+ SCM proc, vm_cont, cont;
POP (proc);
SYNC_ALL ();
- cont = scm_i_make_continuation (&first, vm, capture_vm_cont (vp));
- ASSERT (sp == vp->sp);
- ASSERT (fp == vp->fp);
+ /* In contrast to call/cc, tail-call/cc captures the continuation without the
+ stack frame. */
+ vm_cont = vm_capture_continuation (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));
+ cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
PUSH (proc);
nargs = 1;
goto vm_tail_call;
}
- else if (SCM_VALUESP (cont))
- {
- /* multiple values returned to continuation */
- SCM values;
- values = scm_struct_ref (cont, SCM_INUM0);
- nvalues = scm_ilength (values);
- PUSH_LIST (values, scm_is_null);
- goto vm_return_values;
- }
else
{
- PUSH (cont);
- goto vm_return;
+ /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
+ does a return from the frame, either to the RA or MVRA. */
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ NEXT;
}
}
scm_puts (">", port);
}
+/* In theory, a number of vm instances can be active in the call trace, and we
+ only want to reify the continuations of those in the current continuation
+ root. I don't see a nice way to do this -- ideally it would involve dynwinds,
+ and previous values of the *the-vm* fluid within the current continuation
+ root. But we don't have access to continuation roots in the dynwind stack.
+ So, just punt for now, we just capture the continuation for the current VM.
+
+ While I'm on the topic, ideally we could avoid copying the C stack if the
+ continuation root is inside VM code, and call/cc was invoked within that same
+ call to vm_run; but that's currently not implemented.
+ */
static SCM
-capture_vm_cont (struct scm_vm *vp)
+vm_capture_continuation (SCM *stack_base,
+ SCM *fp, SCM *sp, scm_t_uint8 *ra, scm_t_uint8 *mvra)
{
- struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
- p->stack_size = vp->sp - vp->stack_base + 1;
+ struct scm_vm_cont *p;
+
+ p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+ p->stack_size = sp - stack_base + 1;
p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
-#ifdef VM_ENABLE_STACK_NULLING
- if (vp->sp >= vp->stack_base)
+#if defined(VM_ENABLE_STACK_NULLING) && 0
+ /* Tail continuations leave their frame on the stack for subsequent
+ application, but don't capture the frame -- so there are some elements on
+ the stack then, and this check doesn't work, so disable it for now. */
+ if (sp >= vp->stack_base)
if (!vp->sp[0] || vp->sp[1])
abort ();
memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
#endif
- p->ip = vp->ip;
- p->sp = vp->sp;
- p->fp = vp->fp;
- memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
- p->reloc = p->stack_base - vp->stack_base;
+ p->ra = ra;
+ p->mvra = mvra;
+ p->sp = sp;
+ p->fp = fp;
+ memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
+ p->reloc = p->stack_base - stack_base;
return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
static void
-reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
{
- struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
- if (vp->stack_size < p->stack_size)
+ struct scm_vm *vp;
+ struct scm_vm_cont *cp;
+ SCM *argv_copy;
+
+ argv_copy = alloca (n * sizeof(SCM));
+ memcpy (argv_copy, argv, n * sizeof(SCM));
+
+ vp = SCM_VM_DATA (vm);
+ cp = SCM_VM_CONT_DATA (cont);
+
+ if (n == 0 && !cp->mvra)
+ scm_misc_error (NULL, "Too few values returned to continuation",
+ SCM_EOL);
+
+ if (vp->stack_size < cp->stack_size + n + 1)
{
/* puts ("FIXME: Need to expand"); */
abort ();
}
#ifdef VM_ENABLE_STACK_NULLING
{
- scm_t_ptrdiff nzero = (vp->sp - p->sp);
+ scm_t_ptrdiff nzero = (vp->sp - cp->sp);
if (nzero > 0)
- memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
+ memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
/* actually nzero should always be negative, because vm_reset_stack will
unwind the stack to some point *below* this continuation */
}
#endif
- vp->ip = p->ip;
- vp->sp = p->sp;
- vp->fp = p->fp;
- memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
-}
+ vp->sp = cp->sp;
+ vp->fp = cp->fp;
+ memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
-/* In theory, a number of vm instances can be active in the call trace, and we
- only want to reify the continuations of those in the current continuation
- root. I don't see a nice way to do this -- ideally it would involve dynwinds,
- and previous values of the *the-vm* fluid within the current continuation
- root. But we don't have access to continuation roots in the dynwind stack.
- So, just punt for now -- take the current value of *the-vm*.
+ if (n == 1 || !cp->mvra)
+ {
+ vp->ip = cp->ra;
+ vp->sp++;
+ *vp->sp = argv_copy[0];
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ vp->sp++;
+ *vp->sp = scm_from_size_t (n);
+ vp->ip = cp->mvra;
+ }
+}
- While I'm on the topic, ideally we could avoid copying the C stack if the
- continuation root is inside VM code, and call/cc was invoked within that same
- call to vm_run; but that's currently not implemented.
- */
SCM
scm_i_vm_capture_continuation (SCM vm)
{
- return capture_vm_cont (SCM_VM_DATA (vm));
-}
-
-void
-scm_i_vm_reinstate_continuation (SCM vm, SCM cont)
-{
- reinstate_vm_cont (SCM_VM_DATA (vm), cont);
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ return vm_capture_continuation (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL);
}
static void
SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
struct scm_vm_cont {
- scm_t_uint8 *ip;
SCM *sp;
SCM *fp;
+ scm_t_uint8 *ra, *mvra;
scm_t_ptrdiff stack_size;
SCM *stack_base;
scm_t_ptrdiff reloc;
#define SCM_VM_CONT_P(OBJ) (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) == scm_tc7_vm_cont)
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
-SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
-SCM_INTERNAL void scm_i_vm_reinstate_continuation (SCM vm, SCM cont);
-
SCM_API SCM scm_load_compiled_with_vm (SCM file);
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 void scm_i_vm_cont_print (SCM x, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_vm (void);
HCoop / bpt / guile.git / commitdiff