diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index 59192d1ea..42b66107c 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -26,6 +26,7 @@ #include "cache-internal.h" #include "extensions.h" #include "fluids.h" +#include "frames.h" #include "gc-inline.h" #include "goops.h" #include "gsubr.h" @@ -346,6 +347,18 @@ current_module (scm_thread *thread) return scm_i_current_module (thread); } +static void +push_prompt (scm_thread *thread, jmp_buf *registers, uint8_t escape_only_p, + SCM tag, const union scm_vm_stack_element *sp, void *ra) +{ + struct scm_vm *vp = &thread->vm; + scm_t_dynstack_prompt_flags flags; + + flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; + scm_dynstack_push_prompt (&thread->dynstack, flags, tag, + vp->stack_top - vp->fp, vp->stack_top - sp, + ra, registers); +} void scm_bootstrap_intrinsics (void) @@ -401,6 +414,7 @@ scm_bootstrap_intrinsics (void) scm_vm_intrinsics.error_wrong_number_of_values = error_wrong_number_of_values; scm_vm_intrinsics.allocate_words = allocate_words; scm_vm_intrinsics.current_module = current_module; + scm_vm_intrinsics.push_prompt = push_prompt; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_intrinsics", diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index 7a122d983..c44f83243 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -64,6 +64,10 @@ typedef void (*scm_t_scm_noreturn_intrinsic) (SCM) SCM_NORETURN; typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN; typedef SCM (*scm_t_scm_from_thread_u64_intrinsic) (scm_thread*, uint64_t); typedef SCM (*scm_t_scm_from_thread_intrinsic) (scm_thread*); +typedef void (*scm_t_thread_regs_u8_scm_sp_ra_intrinsic) (scm_thread*, jmp_buf*, + uint8_t, SCM, + const union scm_vm_stack_element*, + void*); #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -129,6 +133,7 @@ typedef SCM (*scm_t_scm_from_thread_intrinsic) (scm_thread*); M(thread, apply_non_program, "apply-non-program", APPLY_NON_PROGRAM) \ M(scm_from_thread_u64, allocate_words, "allocate-words", ALLOCATE_WORDS) \ M(scm_from_thread, current_module, "current-module", CURRENT_MODULE) \ + M(thread_regs_u8_scm_sp_ra, push_prompt, "push-prompt", PUSH_PROMPT) \ /* 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 357acebc6..7e4bd8966 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1671,7 +1671,6 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) uint32_t tag, proc_slot; int32_t offset; uint8_t escape_only_p; - scm_t_dynstack_prompt_flags flags; UNPACK_24 (op, tag); escape_only_p = ip[1] & 0x1; @@ -1680,14 +1679,11 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) offset >>= 8; /* Sign extension */ /* Push the prompt onto the dynamic stack. */ - flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; SYNC_IP (); - scm_dynstack_push_prompt (&thread->dynstack, flags, - SP_REF (tag), - VP->stack_top - VP->fp, - VP->stack_top - FP_SLOT (proc_slot), - ip + offset, - registers); + scm_vm_intrinsics.push_prompt (thread, registers, escape_only_p, + SP_REF (tag), FP_SLOT (proc_slot), + ip + offset); + NEXT (3); }