diff --git a/libguile/control.c b/libguile/control.c index df3a2dccd..38378aed2 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -74,8 +74,8 @@ static const uint32_t compose_continuation_code[] = }; -static SCM -make_partial_continuation (SCM vm_cont) +SCM +scm_i_make_composable_continuation (SCM vmcont) { scm_t_bits nfree = 1; scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION; @@ -83,113 +83,11 @@ make_partial_continuation (SCM vm_cont) ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); SCM_SET_CELL_WORD_1 (ret, compose_continuation_code); - SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vm_cont); + SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vmcont); return ret; } -static SCM -reify_partial_continuation (struct scm_vm *vp, - union scm_vm_stack_element *saved_fp, - union scm_vm_stack_element *saved_sp, - uint32_t *saved_ip, - jmp_buf *saved_registers, - scm_t_dynstack *dynstack, - jmp_buf *current_registers) -{ - SCM vm_cont; - uint32_t flags; - union scm_vm_stack_element *base_fp; - - flags = SCM_F_VM_CONT_PARTIAL; - /* If we are aborting to a prompt that has the same registers as those - of the abort, it means there are no intervening C frames on the - stack, and so the continuation can be relocated elsewhere on the - stack: it is rewindable. */ - if (saved_registers && saved_registers == current_registers) - flags |= SCM_F_VM_CONT_REWINDABLE; - - /* Walk the stack until we find the first frame newer than saved_fp. - We will save the stack until that frame. It used to be that we - could determine the stack base in O(1) time, but that's no longer - the case, since the thunk application doesn't occur where the - prompt is saved. */ - for (base_fp = vp->fp; - SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp; - base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp)); - - if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp) - abort(); - - scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp); - - /* Capture from the base_fp to the top thunk application frame. */ - vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack, - flags); - - return make_partial_continuation (vm_cont); -} - -void -scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, - jmp_buf *current_registers) -{ - SCM cont; - scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; - scm_t_bits *prompt; - scm_t_dynstack_prompt_flags flags; - ptrdiff_t fp_offset, sp_offset; - union scm_vm_stack_element *fp, *sp; - uint32_t *ip; - jmp_buf *registers; - size_t i; - - prompt = scm_dynstack_find_prompt (dynstack, tag, - &flags, &fp_offset, &sp_offset, &ip, - ®isters); - - if (!prompt) - scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag)); - - fp = vp->stack_top - fp_offset; - sp = vp->stack_top - sp_offset; - - /* Only reify if the continuation referenced in the handler. */ - if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY) - cont = SCM_BOOL_F; - else - { - scm_t_dynstack *captured; - - captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt)); - cont = reify_partial_continuation (vp, fp, sp, ip, registers, captured, - current_registers); - } - - /* Unwind. */ - scm_dynstack_unwind (dynstack, prompt); - - /* Restore VM regs */ - vp->fp = fp; - vp->sp = sp - n - 1; - vp->ip = ip; - - /* Since we're jumping down, we should always have enough space. */ - if (vp->sp < vp->stack_limit) - abort (); - - /* Push vals */ - vp->sp[n].as_scm = cont; - for (i = 0; i < n; i++) - vp->sp[n - i - 1].as_scm = argv[i]; - - /* Jump! */ - longjmp (*registers, 1); - - /* Shouldn't get here */ - abort (); -} - SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0, (SCM tag, SCM args), "Abort to the nearest prompt with tag @var{tag}, yielding the\n" @@ -205,7 +103,7 @@ SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0, for (i = 0; i < n; i++, args = scm_cdr (args)) argv[i] = scm_car (args); - scm_c_abort (&SCM_I_CURRENT_THREAD->vm, tag, n, argv, NULL); + scm_i_vm_abort (&SCM_I_CURRENT_THREAD->vm, tag, n, argv, NULL); /* Oh, what, you're still here? The abort must have been reinstated. Actually, that's quite impossible, given that we're already in C-land here, so... diff --git a/libguile/control.h b/libguile/control.h index c2bb5b5e3..4f64f41ea 100644 --- a/libguile/control.h +++ b/libguile/control.h @@ -20,16 +20,14 @@ #ifndef SCM_CONTROL_H #define SCM_CONTROL_H -#include - #include "libguile/scm.h" SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp, ptrdiff_t saved_stack_depth); -SCM_INTERNAL void scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, - jmp_buf *registers) SCM_NORETURN; +SCM_INTERNAL SCM scm_i_make_composable_continuation (SCM vmcont); + SCM_INTERNAL SCM scm_abort_to_prompt_star (SCM tag, SCM args) SCM_NORETURN; diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index 894db5abb..a46f73191 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -57,6 +57,7 @@ typedef void (*scm_t_thread_scm_noreturn_intrinsic) (scm_thread*, SCM) SCM_NORET 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); typedef int (*scm_t_int_from_scm_intrinsic) (SCM); +typedef void (*scm_t_thread_regs_intrinsic) (scm_thread*, jmp_buf*); #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -111,6 +112,7 @@ typedef int (*scm_t_int_from_scm_intrinsic) (SCM); M(scm_from_thread_regs, capture_continuation, "capture-continuation", CAPTURE_CONTINUATION) \ M(thread_regs_scm, compose_continuation, "compose-continuation", COMPOSE_CONTINUATION) \ M(int_from_scm, rest_arg_length, "rest-arg-length", REST_ARG_LENGTH) \ + M(thread_regs, abort_to_prompt, "abort-to-prompt", ABORT_TO_PROMPT) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/throw.c b/libguile/throw.c index 1ad7294f1..7372ccb04 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -195,7 +195,7 @@ abort_to_prompt (SCM prompt_tag, SCM tag, SCM args) for (i = 1; i < n; i++, args = scm_cdr (args)) argv[i] = scm_car (args); - scm_c_abort (&SCM_I_CURRENT_THREAD->vm, prompt_tag, n, argv, NULL); + scm_i_vm_abort (&SCM_I_CURRENT_THREAD->vm, prompt_tag, n, argv, NULL); /* Oh, what, you're still here? The abort must have been reinstated. Actually, that's quite impossible, given that we're already in C-land here, so... diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 9ff471100..7fc549970 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -781,15 +781,12 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) */ VM_DEFINE_OP (16, abort, "abort", OP1 (X32)) { - uint32_t nlocals = FRAME_LOCALS_COUNT (); - - ASSERT (nlocals >= 2); /* FIXME: Really we should capture the caller's registers. Until then, manually advance the IP so that when the prompt resumes, it continues with the next instruction. */ ip++; SYNC_IP (); - vm_abort (VP, FP_REF (1), nlocals - 2, registers); + scm_vm_intrinsics.abort_to_prompt (thread, registers); /* vm_abort should not return */ abort (); diff --git a/libguile/vm.c b/libguile/vm.c index 58badfa91..29f33e261 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -303,26 +303,6 @@ static void vm_dispatch_abort_hook (struct scm_vm *vp) vp->sp, SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); } -static void -vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, - jmp_buf *current_registers) SCM_NORETURN; - -static void -vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, - jmp_buf *current_registers) -{ - size_t i; - SCM *argv; - - argv = alloca (nargs * sizeof (SCM)); - for (i = 0; i < nargs; i++) - argv[i] = vp->sp[nargs - i - 1].as_scm; - - vp->sp = vp->fp; - - scm_c_abort (vp, tag, nargs, argv, current_registers); -} - /* * VM Error Handling @@ -1314,6 +1294,129 @@ rest_arg_length (SCM x) return len; } +static SCM +capture_delimited_continuation (struct scm_vm *vp, + union scm_vm_stack_element *saved_fp, + union scm_vm_stack_element *saved_sp, + uint32_t *saved_ip, + jmp_buf *saved_registers, + scm_t_dynstack *dynstack, + jmp_buf *current_registers) +{ + SCM vm_cont; + uint32_t flags; + union scm_vm_stack_element *base_fp; + + flags = SCM_F_VM_CONT_PARTIAL; + /* If we are aborting to a prompt that has the same registers as those + of the abort, it means there are no intervening C frames on the + stack, and so the continuation can be relocated elsewhere on the + stack: it is rewindable. */ + if (saved_registers && saved_registers == current_registers) + flags |= SCM_F_VM_CONT_REWINDABLE; + + /* Walk the stack until we find the first frame newer than saved_fp. + We will save the stack until that frame. It used to be that we + could determine the stack base in O(1) time, but that's no longer + the case, since the thunk application doesn't occur where the + prompt is saved. */ + for (base_fp = vp->fp; + SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp; + base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp)); + + if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp) + abort(); + + scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp); + + /* Capture from the base_fp to the top thunk application frame. */ + vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack, + flags); + + return scm_i_make_composable_continuation (vm_cont); +} + +void +scm_i_vm_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, + jmp_buf *current_registers) +{ + SCM cont; + scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; + scm_t_bits *prompt; + scm_t_dynstack_prompt_flags flags; + ptrdiff_t fp_offset, sp_offset; + union scm_vm_stack_element *fp, *sp; + uint32_t *ip; + jmp_buf *registers; + size_t i; + + prompt = scm_dynstack_find_prompt (dynstack, tag, + &flags, &fp_offset, &sp_offset, &ip, + ®isters); + + if (!prompt) + scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag)); + + fp = vp->stack_top - fp_offset; + sp = vp->stack_top - sp_offset; + + /* Only reify if the continuation referenced in the handler. */ + if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY) + cont = SCM_BOOL_F; + else + { + scm_t_dynstack *captured; + + captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt)); + cont = capture_delimited_continuation (vp, fp, sp, ip, registers, captured, + current_registers); + } + + /* Unwind. */ + scm_dynstack_unwind (dynstack, prompt); + + /* Restore VM regs */ + vp->fp = fp; + vp->sp = sp - n - 1; + vp->ip = ip; + + /* Since we're jumping down, we should always have enough space. */ + if (vp->sp < vp->stack_limit) + abort (); + + /* Push vals */ + vp->sp[n].as_scm = cont; + for (i = 0; i < n; i++) + vp->sp[n - i - 1].as_scm = argv[i]; + + /* Jump! */ + longjmp (*registers, 1); + + /* Shouldn't get here */ + abort (); +} + +static void +abort_to_prompt (scm_thread *thread, jmp_buf *current_registers) +{ + struct scm_vm *vp = &thread->vm; + SCM tag; + size_t nargs, i; + SCM *argv; + + tag = SCM_FRAME_LOCAL (vp->fp, 1); + nargs = frame_locals_count (thread) - 2; + + /* FIXME: Avoid this alloca. */ + argv = alloca (nargs * sizeof (SCM)); + for (i = 0; i < nargs; i++) + argv[i] = vp->sp[nargs - i - 1].as_scm; + + vp->sp = vp->fp; + + scm_i_vm_abort (vp, tag, nargs, argv, current_registers); +} + SCM scm_call_n (SCM proc, SCM *argv, size_t nargs) { @@ -1661,6 +1764,7 @@ scm_bootstrap_vm (void) scm_vm_intrinsics.capture_continuation = capture_continuation; scm_vm_intrinsics.compose_continuation = compose_continuation; scm_vm_intrinsics.rest_arg_length = rest_arg_length; + scm_vm_intrinsics.abort_to_prompt = abort_to_prompt; sym_vm_run = scm_from_latin1_symbol ("vm-run"); sym_vm_error = scm_from_latin1_symbol ("vm-error"); diff --git a/libguile/vm.h b/libguile/vm.h index 9b97a6aa9..7d4f34294 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -20,6 +20,8 @@ #ifndef _SCM_VM_H_ #define _SCM_VM_H_ +#include + #include #include @@ -120,6 +122,8 @@ SCM_INTERNAL SCM scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top, uint32_t *ra, scm_t_dynstack *dynstack, uint32_t flags); +SCM_INTERNAL void scm_i_vm_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, + jmp_buf *registers) SCM_NORETURN; SCM_INTERNAL int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame); SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate);