diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index aa242416e..2022138c2 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -55,6 +55,7 @@ typedef SCM (*scm_t_scm_from_scm_scm_scmp_sp_intrinsic) (SCM, SCM, SCM*, const union scm_vm_stack_element*); typedef void (*scm_t_thread_scm_noreturn_intrinsic) (scm_thread*, SCM) SCM_NORETURN; typedef SCM (*scm_t_scm_from_thread_regs_intrinsic) (scm_thread*, jmp_buf*); +typedef void (*scm_t_thread_regs_scm_intrinsic) (scm_thread*, jmp_buf*, SCM); #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -107,6 +108,7 @@ typedef SCM (*scm_t_scm_from_thread_regs_intrinsic) (scm_thread*, jmp_buf*); M(scm_from_scm_scm_scmp_sp, foreign_call, "foreign-call", FOREIGN_CALL) \ M(thread_scm_noreturn, reinstate_continuation_x, "reinstate-continuation!", REINSTATE_CONTINUATION_X) \ M(scm_from_thread_regs, capture_continuation, "capture-continuation", CAPTURE_CONTINUATION) \ + M(thread_regs_scm, compose_continuation, "compose-continuation", COMPOSE_CONTINUATION) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 3b46a6f0f..a11d8cd40 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -696,10 +696,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), cont_idx); SYNC_IP (); - VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), - vm_error_continuation_not_rewindable (vmcont)); - vm_reinstate_partial_continuation (VP, vmcont, FRAME_LOCALS_COUNT_FROM (1), - &thread->dynstack, registers); + scm_vm_intrinsics.compose_continuation (thread, registers, vmcont); CACHE_REGISTER (); NEXT (0); } diff --git a/libguile/vm.c b/libguile/vm.c index 662b3d627..fdf97276d 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -323,78 +323,6 @@ vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, scm_c_abort (vp, tag, nargs, argv, current_registers); } -struct vm_reinstate_partial_continuation_data -{ - struct scm_vm *vp; - struct scm_vm_cont *cp; -}; - -static void * -vm_reinstate_partial_continuation_inner (void *data_ptr) -{ - struct vm_reinstate_partial_continuation_data *data = data_ptr; - struct scm_vm *vp = data->vp; - struct scm_vm_cont *cp = data->cp; - - memcpy (vp->fp - cp->stack_size, - cp->stack_bottom, - cp->stack_size * sizeof (*cp->stack_bottom)); - - vp->fp -= cp->fp_offset; - vp->ip = cp->ra; - - return NULL; -} - -static void -vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, - scm_t_dynstack *dynstack, - jmp_buf *registers) -{ - struct vm_reinstate_partial_continuation_data data; - struct scm_vm_cont *cp; - union scm_vm_stack_element *args; - ptrdiff_t old_fp_offset; - - args = alloca (nargs * sizeof (*args)); - memcpy (args, vp->sp, nargs * sizeof (*args)); - - cp = SCM_VM_CONT_DATA (cont); - - old_fp_offset = vp->stack_top - vp->fp; - - vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1)); - - data.vp = vp; - data.cp = cp; - GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data); - - /* The resume continuation will expect ARGS on the stack as if from a - multiple-value return. Fill in the closure slot with #f, and copy - the arguments into place. */ - vp->sp[nargs].as_scm = SCM_BOOL_F; - memcpy (vp->sp, args, nargs * sizeof (*args)); - - /* The prompt captured a slice of the dynamic stack. Here we wind - those entries onto the current thread's stack. We also have to - relocate any prompts that we see along the way. */ - { - scm_t_bits *walk; - - for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); - SCM_DYNSTACK_TAG (walk); - walk = SCM_DYNSTACK_NEXT (walk)) - { - scm_t_bits tag = SCM_DYNSTACK_TAG (walk); - - if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) - scm_dynstack_wind_prompt (dynstack, walk, old_fp_offset, registers); - else - scm_dynstack_wind_1 (dynstack, walk); - } - } -} - /* * VM Error Handling @@ -412,7 +340,6 @@ static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_number_of_values (uint32_t expected) SCM_NORETURN SCM_NOINLINE; -static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; static void vm_throw (SCM key, SCM args) @@ -503,12 +430,6 @@ vm_error_wrong_number_of_values (uint32_t expected) scm_from_uint32 (expected)); } -static void -vm_error_continuation_not_rewindable (SCM cont) -{ - vm_error ("Unrewindable partial continuation", cont); -} - @@ -1274,7 +1195,7 @@ reinstate_continuation_x (scm_thread *thread, SCM cont) "invoking continuation would cross continuation barrier: ~A", scm_list_1 (cont)); - n = frame_locals_count (thread) - 1, + n = frame_locals_count (thread) - 1; argv = alloca (n * sizeof (*argv)); memcpy (argv, vp->sp, n * sizeof (*argv)); @@ -1312,6 +1233,83 @@ capture_continuation (scm_thread *thread, jmp_buf *registers) return scm_i_make_continuation (registers, thread, vm_cont); } +struct compose_continuation_data +{ + struct scm_vm *vp; + struct scm_vm_cont *cp; +}; + +static void * +compose_continuation_inner (void *data_ptr) +{ + struct compose_continuation_data *data = data_ptr; + struct scm_vm *vp = data->vp; + struct scm_vm_cont *cp = data->cp; + + memcpy (vp->fp - cp->stack_size, + cp->stack_bottom, + cp->stack_size * sizeof (*cp->stack_bottom)); + + vp->fp -= cp->fp_offset; + vp->ip = cp->ra; + + return NULL; +} + +static void +compose_continuation (scm_thread *thread, jmp_buf *registers, SCM cont) +{ + struct scm_vm *vp = &thread->vm; + size_t nargs; + struct compose_continuation_data data; + struct scm_vm_cont *cp; + union scm_vm_stack_element *args; + ptrdiff_t old_fp_offset; + + if (SCM_UNLIKELY (! SCM_VM_CONT_REWINDABLE_P (cont))) + vm_error ("Unrewindable partial continuation", cont); + + nargs = frame_locals_count (thread) - 1; + args = alloca (nargs * sizeof (*args)); + memcpy (args, vp->sp, nargs * sizeof (*args)); + + cp = SCM_VM_CONT_DATA (cont); + + old_fp_offset = vp->stack_top - vp->fp; + + vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1)); + + data.vp = vp; + data.cp = cp; + GC_call_with_alloc_lock (compose_continuation_inner, &data); + + /* The resumed continuation will expect ARGS on the stack as if from a + multiple-value return. Fill in the closure slot with #f, and copy + the arguments into place. */ + vp->sp[nargs].as_scm = SCM_BOOL_F; + memcpy (vp->sp, args, nargs * sizeof (*args)); + + /* The prompt captured a slice of the dynamic stack. Here we wind + those entries onto the current thread's stack. We also have to + relocate any prompts that we see along the way. */ + { + scm_t_bits *walk; + + for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); + SCM_DYNSTACK_TAG (walk); + walk = SCM_DYNSTACK_NEXT (walk)) + { + scm_t_bits tag = SCM_DYNSTACK_TAG (walk); + + if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) + scm_dynstack_wind_prompt (&thread->dynstack, walk, old_fp_offset, + registers); + else + scm_dynstack_wind_1 (&thread->dynstack, walk); + } + } +} + SCM scm_call_n (SCM proc, SCM *argv, size_t nargs) { @@ -1657,6 +1655,7 @@ scm_bootstrap_vm (void) scm_vm_intrinsics.push_interrupt_frame = push_interrupt_frame; scm_vm_intrinsics.reinstate_continuation_x = reinstate_continuation_x; scm_vm_intrinsics.capture_continuation = capture_continuation; + scm_vm_intrinsics.compose_continuation = compose_continuation; sym_vm_run = scm_from_latin1_symbol ("vm-run"); sym_vm_error = scm_from_latin1_symbol ("vm-error");