diff options
Diffstat (limited to 'libguile/vm-i-system.c')
-rw-r--r-- | libguile/vm-i-system.c | 259 |
1 files changed, 114 insertions, 145 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 546c9e09f..dab268f3a 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -744,83 +744,70 @@ VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0, 3) VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1) { - SCM x; nargs = FETCH (); vm_call: - x = sp[-nargs]; + program = sp[-nargs]; VM_HANDLE_INTERRUPTS; - /* - * Subprogram call - */ - if (SCM_PROGRAM_P (x)) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) { - program = x; - CACHE_PROGRAM (); - fp = sp - nargs + 1; - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); - ip = SCM_C_OBJCODE_BASE (bp); - ENTER_HOOK (); - APPLY_HOOK (); - NEXT; - } - if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) - { - sp[-nargs] = SCM_STRUCT_PROCEDURE (x); - goto vm_call; - } - /* - * Other interpreted or compiled call - */ - if (!scm_is_false (scm_procedure_p (x))) - { - SCM ret; - /* At this point, the stack contains the frame, the procedure and each one - of its arguments. */ - SYNC_REGISTER (); - ret = apply_foreign (sp[-nargs], - sp - nargs + 1, - nargs, - vp->stack_limit - sp + 1); - NULLSTACK_FOR_NONLOCAL_EXIT (); - DROPN (nargs + 1); /* drop args and procedure */ - DROP_FRAME (); - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) + if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) { - /* truncate values */ - ret = scm_struct_ref (ret, SCM_INUM0); - if (scm_is_null (ret)) - goto vm_error_not_enough_values; - PUSH (SCM_CAR (ret)); + sp[-nargs] = SCM_STRUCT_PROCEDURE (program); + goto vm_call; + } + else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + && SCM_SMOB_APPLICABLE_P (program)) + { + SYNC_REGISTER (); + sp[-nargs] = scm_i_smob_apply_trampoline (program); + goto vm_call; } else - PUSH (ret); - NEXT; + goto vm_error_wrong_type_apply; } - program = x; - goto vm_error_wrong_type_apply; + CACHE_PROGRAM (); + fp = sp - nargs + 1; + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); + ip = SCM_C_OBJCODE_BASE (bp); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; } VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1) { - register SCM x; nargs = FETCH (); + vm_tail_call: - x = sp[-nargs]; + program = sp[-nargs]; VM_HANDLE_INTERRUPTS; - /* - * Tail call - */ - if (SCM_PROGRAM_P (x)) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) + { + if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (program); + goto vm_tail_call; + } + else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + && SCM_SMOB_APPLICABLE_P (program)) + { + SYNC_REGISTER (); + sp[-nargs] = scm_i_smob_apply_trampoline (program); + goto vm_tail_call; + } + else + goto vm_error_wrong_type_apply; + } + else { int i; #ifdef VM_ENABLE_STACK_NULLING @@ -831,7 +818,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1) EXIT_HOOK (); /* switch programs */ - program = x; CACHE_PROGRAM (); /* shuffle down the program and the arguments */ for (i = -1, sp = sp - nargs + 1; i < nargs; i++) @@ -847,43 +833,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1) APPLY_HOOK (); NEXT; } - if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) - { - sp[-nargs] = SCM_STRUCT_PROCEDURE (x); - goto vm_tail_call; - } - /* - * Other interpreted or compiled call - */ - if (!scm_is_false (scm_procedure_p (x))) - { - SCM ret; - SYNC_REGISTER (); - ret = apply_foreign (sp[-nargs], - sp - nargs + 1, - nargs, - vp->stack_limit - sp + 1); - NULLSTACK_FOR_NONLOCAL_EXIT (); - DROPN (nargs + 1); /* drop args and procedure */ - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - { - /* multiple values returned to continuation */ - ret = scm_struct_ref (ret, SCM_INUM0); - nvalues = scm_ilength (ret); - PUSH_LIST (ret, scm_is_null); - goto vm_return_values; - } - else - { - PUSH (ret); - goto vm_return; - } - } - - program = x; - - goto vm_error_wrong_type_apply; } VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1) @@ -955,6 +904,54 @@ VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1) } } +VM_DEFINE_INSTRUCTION (81, smob_call, "smob-call", 1, -1, -1) +{ + SCM smob, ret; + SCM (*subr)(); + nargs = FETCH (); + POP (smob); + + subr = SCM_SMOB_DESCRIPTOR (smob).apply; + + VM_HANDLE_INTERRUPTS; + SYNC_REGISTER (); + + switch (nargs) + { + case 0: + ret = subr (smob); + break; + case 1: + ret = subr (smob, sp[0]); + break; + case 2: + ret = subr (smob, sp[-1], sp[0]); + break; + case 3: + ret = subr (smob, sp[-2], sp[-1], sp[0]); + break; + default: + abort (); + } + + NULLSTACK_FOR_NONLOCAL_EXIT (); + DROPN (nargs + 1); /* drop args and procedure */ + + if (SCM_UNLIKELY (SCM_VALUESP (ret))) + { + /* multiple values returned to continuation */ + ret = scm_struct_ref (ret, SCM_INUM0); + nvalues = scm_ilength (ret); + PUSH_LIST (ret, scm_is_null); + goto vm_return_values; + } + else + { + PUSH (ret); + goto vm_return; + } +} + VM_DEFINE_INSTRUCTION (56, tail_call_nargs, "tail-call/nargs", 0, 0, 1) { SCM x; @@ -975,7 +972,6 @@ VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 1) VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1) { - SCM x; scm_t_int32 offset; scm_t_uint8 *mvra; @@ -984,65 +980,38 @@ VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1) mvra = ip + offset; vm_mv_call: - x = sp[-nargs]; + program = sp[-nargs]; VM_HANDLE_INTERRUPTS; - /* - * Subprogram call - */ - if (SCM_PROGRAM_P (x)) - { - program = x; - CACHE_PROGRAM (); - fp = sp - nargs + 1; - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); - ip = SCM_C_OBJCODE_BASE (bp); - ENTER_HOOK (); - APPLY_HOOK (); - NEXT; - } - if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) { - sp[-nargs] = SCM_STRUCT_PROCEDURE (x); - goto vm_mv_call; - } - /* - * Other interpreted or compiled call - */ - if (!scm_is_false (scm_procedure_p (x))) - { - SCM ret; - /* At this point, the stack contains the frame, the procedure and each one - of its arguments. */ - SYNC_REGISTER (); - ret = apply_foreign (sp[-nargs], - sp - nargs + 1, - nargs, - vp->stack_limit - sp + 1); - NULLSTACK_FOR_NONLOCAL_EXIT (); - DROPN (nargs + 1); /* drop args and procedure */ - DROP_FRAME (); - - if (SCM_VALUESP (ret)) + if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (program); + goto vm_mv_call; + } + else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + && SCM_SMOB_APPLICABLE_P (program)) { - SCM len; - ret = scm_struct_ref (ret, SCM_INUM0); - len = scm_length (ret); - PUSH_LIST (ret, scm_is_null); - PUSH (len); - ip = mvra; + SYNC_REGISTER (); + sp[-nargs] = scm_i_smob_apply_trampoline (program); + goto vm_mv_call; } else - PUSH (ret); - NEXT; + goto vm_error_wrong_type_apply; } - program = x; - goto vm_error_wrong_type_apply; + CACHE_PROGRAM (); + fp = sp - nargs + 1; + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); + ip = SCM_C_OBJCODE_BASE (bp); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; } VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1) |