diff options
author | Andy Wingo <wingo@pobox.com> | 2010-02-08 22:59:25 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-02-08 22:59:25 +0100 |
commit | d8873dfe4754daf031a6709738bd31afa8edb443 (patch) | |
tree | dbad856934bd9069258d0db8e010f9a9a556ef69 | |
parent | 269479e31f70d40a82b75be87c1b2a7363c85696 (diff) | |
download | guile-d8873dfe4754daf031a6709738bd31afa8edb443.tar.gz |
continuations return multiple values on the stack
* libguile/vm.h (struct scm_vm_cont): Instead of saving the "IP", save
"RA" and "MVRA". That is, save singly-valued and multiply-valued
return addresses, so that we can return multiple values on the stack.
(scm_i_vm_reinstate_continuation): Remove.
* libguile/vm.c (vm_capture_continuation): Rename from capture_vm_cont,
and change the prototype so we can capture the RA and MVRA, and so
that tail calls to call/cc can capture a continuation without the
call/cc application frame.
(vm_return_to_continuation): Rename from reinstate_vm_cont, and take
arguments to return to the continuation. Handles returning to single
or multiple-value RA.
(scm_i_vm_capture_continuation): Change to invoke
vm_capture_continuation. Kept around for the benefit of make-stack.
* libguile/vm-i-system.c (continuation-call): Handle reinstatement of
the VM stack, with arguments.
(call/cc, tail-call/cc): Adapt to new vm_capture_continuation
prototype. tail-call/cc captures tail continuations.
* libguile/stacks.c (scm_make_stack): Update for scm_vm_cont structure
change.
* libguile/continuations.h (struct scm_contregs): Remove throw_value
member, which was used to return a value to a continuation.
(scm_i_check_continuation): New internal function, checks that a
continuation may be reinstated.
(scm_i_reinstate_continuation): Replaces scm_i_continuation_call; just
reinstates the C stack.
(scm_i_contregs_vm, scm_i_contregs_vm_cont): New internal accessors.
* libguile/continuations.c (scm_i_make_continuation): Return
SCM_UNDEFINED if we are returning again.
(grow_stack, copy_stack_and_call, scm_dynthrow): Remove extra arg, as
vm opcodes handle value returns.
(copy_stack): No need to instate VM continuation.
(scm_i_reinstate_continuation): Adapt.
-rw-r--r-- | libguile/continuations.c | 61 | ||||
-rw-r--r-- | libguile/continuations.h | 8 | ||||
-rw-r--r-- | libguile/stacks.c | 2 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 65 | ||||
-rw-r--r-- | libguile/vm.c | 107 | ||||
-rw-r--r-- | libguile/vm.h | 6 |
6 files changed, 142 insertions, 107 deletions
diff --git a/libguile/continuations.c b/libguile/continuations.c index fc47d9b40..118c0b61d 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -34,7 +34,6 @@ #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" @@ -54,7 +53,6 @@ static scm_t_bits tc16_continuation; (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) @@ -187,8 +185,8 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) } /* 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) @@ -206,7 +204,6 @@ 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 @@ -238,11 +235,7 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont) 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 @@ -272,13 +265,25 @@ scm_i_continuation_to_frame (SCM continuation) 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} */ @@ -295,7 +300,7 @@ scm_i_continuation_to_frame (SCM continuation) * 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 @@ -307,12 +312,12 @@ static void scm_dynthrow (SCM, SCM); 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); } @@ -332,15 +337,13 @@ 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); - 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; @@ -351,7 +354,6 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, data.dst = dst; scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data); - continuation->throw_value = val; SCM_I_LONGJMP (continuation->jmpbuf, 1); } @@ -377,7 +379,7 @@ scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL) * 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); @@ -392,36 +394,35 @@ scm_dynthrow (SCM cont, SCM val) #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 diff --git a/libguile/continuations.h b/libguile/continuations.h index a9d2feee0..e0a455632 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -44,7 +44,6 @@ typedef struct { - SCM throw_value; scm_i_jmp_buf jmpbuf; SCM dynenv; #ifdef __ia64__ @@ -73,9 +72,14 @@ typedef struct 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); diff --git a/libguile/stacks.c b/libguile/stacks.c index 58155902f..431d6b1e2 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -203,7 +203,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, 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)) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index e5a9d7a0e..6827e79ad 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -982,7 +982,13 @@ VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0) { 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 (); } @@ -1090,10 +1096,11 @@ VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1) 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 */ @@ -1104,22 +1111,14 @@ VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1) 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; } } @@ -1127,12 +1126,17 @@ VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1) 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); @@ -1140,19 +1144,14 @@ VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1) 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; } } diff --git a/libguile/vm.c b/libguile/vm.c index 425e57ed5..66d89a4fe 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -80,72 +80,105 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) 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 diff --git a/libguile/vm.h b/libguile/vm.h index 8540356aa..17445ea51 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -87,9 +87,9 @@ SCM_API SCM scm_vm_trace_level (SCM vm); 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; @@ -98,13 +98,11 @@ struct scm_vm_cont { #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); |