diff options
-rw-r--r-- | libguile/intrinsics.h | 1 | ||||
-rw-r--r-- | libguile/vm-engine.c | 33 | ||||
-rw-r--r-- | libguile/vm.c | 50 |
3 files changed, 46 insertions, 38 deletions
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index 6526abcf9..ac5966114 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -124,6 +124,7 @@ typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN; M(noreturn, error_no_values, "no-values", ERROR_NO_VALUES) \ M(noreturn, error_not_enough_values, "not-enough-values", ERROR_NOT_ENOUGH_VALUES) \ M(u32_noreturn, error_wrong_number_of_values, "wrong-number-of-values", ERROR_WRONG_NUMBER_OF_VALUES) \ + M(thread, apply_non_program, "apply-non-program", APPLY_NON_PROGRAM) \ /* 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 0cf1a0c30..023632975 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2033,36 +2033,9 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) */ VM_DEFINE_OP (142, apply_non_program, "apply-non-program", OP1 (X32)) { - SCM proc = FP_REF (0); - - while (!SCM_PROGRAM_P (proc)) - { - if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) - { - proc = SCM_STRUCT_PROCEDURE (proc); - FP_SET (0, proc); - continue; - } - if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc)) - { - uint32_t n = FRAME_LOCALS_COUNT(); - - /* Shuffle args up. (FIXME: no real need to shuffle; just set - IP and go. ) */ - ALLOC_FRAME (n + 1); - while (n--) - FP_SET (n + 1, FP_REF (n)); - - proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline; - FP_SET (0, proc); - continue; - } - - SYNC_IP(); - vm_error_wrong_type_apply (proc); - } - - ip = SCM_PROGRAM_CODE (proc); + SYNC_IP (); + scm_vm_intrinsics.apply_non_program (thread); + CACHE_REGISTER (); NEXT (0); } diff --git a/libguile/vm.c b/libguile/vm.c index 9e1227472..1b224d435 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -308,7 +308,6 @@ static void vm_dispatch_abort_hook (struct scm_vm *vp) static void vm_error_bad_instruction (uint32_t inst) SCM_NORETURN SCM_NOINLINE; -static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_bad_instruction (uint32_t inst) @@ -317,13 +316,6 @@ vm_error_bad_instruction (uint32_t inst) abort (); } -static void -vm_error_wrong_type_apply (SCM proc) -{ - scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", - scm_list_1 (proc), scm_list_1 (proc)); -} - @@ -1332,6 +1324,47 @@ abort_to_prompt (scm_thread *thread, jmp_buf *current_registers) longjmp (*registers, 1); } +static void +apply_non_program (scm_thread *thread) +{ + struct scm_vm *vp = &thread->vm; + + SCM proc = SCM_FRAME_LOCAL (vp->fp, 0); + + while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) + { + proc = SCM_STRUCT_PROCEDURE (proc); + SCM_FRAME_LOCAL (vp->fp, 0) = proc; + + if (SCM_PROGRAM_P (proc)) + { + vp->ip = SCM_PROGRAM_CODE (proc); + return; + } + } + + if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc)) + { + uint32_t n = frame_locals_count (thread); + + alloc_frame (thread, n + 1); + + /* Although we could make VM modifications to avoid this shuffle, + it's easier to piggy-back on the subr arg parsing machinery. + Hopefully applicable smobs will go away in the mid-term. */ + while (n--) + SCM_FRAME_LOCAL (vp->fp, n + 1) = SCM_FRAME_LOCAL (vp->fp, n); + + proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline; + SCM_FRAME_LOCAL (vp->fp, 0) = proc; + vp->ip = SCM_PROGRAM_CODE (proc); + return; + } + + scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", + scm_list_1 (proc), scm_list_1 (proc)); +} + SCM scm_call_n (SCM proc, SCM *argv, size_t nargs) { @@ -1680,6 +1713,7 @@ scm_bootstrap_vm (void) 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; + scm_vm_intrinsics.apply_non_program = apply_non_program; sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); sym_regular = scm_from_latin1_symbol ("regular"); |