diff --git a/libguile/foreign.c b/libguile/foreign.c index 0992ef4d3..17a3eedb5 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -767,7 +767,9 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, #define CODE(nreq) \ SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \ - SCM_PACK_OP_12_12 (foreign_call, 0, 1) + SCM_PACK_OP_12_12 (foreign_call, 0, 1), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0) #define CODE_10(n) \ CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \ @@ -789,7 +791,7 @@ get_foreign_stub_code (unsigned int nargs) scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented", SCM_EOL); - return &foreign_stub_code[nargs * 2]; + return &foreign_stub_code[nargs * 4]; } static SCM diff --git a/libguile/gsubr.c b/libguile/gsubr.c index b456b220a..e22d16363 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -75,6 +75,8 @@ #define A(nreq) \ SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0, \ 0 @@ -82,11 +84,15 @@ SCM_PACK_OP_24 (assert_nargs_le, nopt + 1), \ SCM_PACK_OP_24 (alloc_frame, nopt + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0 #define C() \ SCM_PACK_OP_24 (bind_rest, 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0, \ 0 @@ -94,17 +100,23 @@ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ SCM_PACK_OP_24 (assert_nargs_le, nreq + nopt + 1), \ SCM_PACK_OP_24 (alloc_frame, nreq + nopt + 1), \ - SCM_PACK_OP_24 (subr_call, 0) + SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0) #define AC(nreq) \ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ SCM_PACK_OP_24 (bind_rest, nreq + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0 #define BC(nopt) \ SCM_PACK_OP_24 (bind_rest, nopt + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0, \ 0 @@ -112,6 +124,8 @@ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0 @@ -212,7 +226,7 @@ static const scm_t_uint32 subr_stub_code[] = { /* (nargs * nargs) + nopt + rest * (nargs + 1) */ #define SUBR_STUB_CODE(nreq,nopt,rest) \ &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest) \ - + nopt + rest * (nreq + nopt + rest + 1)) * 4] + + nopt + rest * (nreq + nopt + rest + 1)) * 6] static const scm_t_uint32* get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest) @@ -265,12 +279,16 @@ scm_i_primitive_code_p (const scm_t_uint32 *code) scm_t_uintptr scm_i_primitive_call_ip (SCM subr) { + size_t i; const scm_t_uint32 *code = SCM_PROGRAM_CODE (subr); - /* A stub is 4 32-bit words long, or 16 bytes. The call will be one + /* A stub is 6 32-bit words long, or 24 bytes. The call will be one instruction, in either the fourth, third, or second word. Return a byte offset from the entry. */ - return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1)); + for (i = 1; i < 4; i++) + if ((code[i] & 0xff) == scm_op_subr_call) + return (scm_t_uintptr) (code + i); + abort (); } SCM diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 4de1971c2..ac8f32e49 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -127,22 +127,6 @@ #define ABORT_CONTINUATION_HOOK() \ RUN_HOOK0 (abort) -/* TODO: Invoke asyncs without trampolining out to C. That will let us - preempt computations via an asynchronous interrupt. */ -#define VM_HANDLE_INTERRUPTS \ - do \ - if (SCM_LIKELY (thread->block_asyncs == 0)) \ - { \ - SCM asyncs = scm_atomic_ref_scm (&thread->pending_asyncs); \ - if (SCM_UNLIKELY (!scm_is_null (asyncs))) \ - { \ - SYNC_IP (); \ - scm_async_tick (); \ - CACHE_SP (); \ - } \ - } \ - while (0) - @@ -282,38 +266,6 @@ #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) -#define RETURN_ONE_VALUE(ret) \ - do { \ - SCM val = ret; \ - union scm_vm_stack_element *old_fp; \ - VM_HANDLE_INTERRUPTS; \ - ALLOC_FRAME (2); \ - old_fp = vp->fp; \ - ip = SCM_FRAME_RETURN_ADDRESS (old_fp); \ - vp->fp = SCM_FRAME_DYNAMIC_LINK (old_fp); \ - /* Clear frame. */ \ - old_fp[0].as_scm = SCM_BOOL_F; \ - old_fp[1].as_scm = SCM_BOOL_F; \ - /* Leave proc. */ \ - SP_SET (0, val); \ - POP_CONTINUATION_HOOK (old_fp); \ - NEXT (0); \ - } while (0) - -/* While we could generate the list-unrolling code here, it's fine for - now to just tail-call (apply values vals). */ -#define RETURN_VALUE_LIST(vals_) \ - do { \ - SCM vals = vals_; \ - VM_HANDLE_INTERRUPTS; \ - ALLOC_FRAME (3); \ - SP_SET (2, vm_builtin_apply); \ - SP_SET (1, vm_builtin_values); \ - SP_SET (0, vals); \ - ip = (scm_t_uint32 *) vm_builtin_apply_code; \ - goto op_tail_apply; \ - } while (0) - #define BR_NARGS(rel) \ scm_t_uint32 expected; \ UNPACK_24 (op, expected); \ @@ -334,8 +286,6 @@ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (2) @@ -351,8 +301,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3) @@ -373,8 +321,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -389,8 +335,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -409,8 +353,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -587,8 +529,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); - VM_HANDLE_INTERRUPTS; - PUSH_CONTINUATION_HOOK (); old_fp = vp->fp; @@ -628,8 +568,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (ip[1], nlocals); label = ip[2]; - VM_HANDLE_INTERRUPTS; - PUSH_CONTINUATION_HOOK (); old_fp = vp->fp; @@ -658,8 +596,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, nlocals); - VM_HANDLE_INTERRUPTS; - RESET_FRAME (nlocals); if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) @@ -685,8 +621,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, nlocals); label = ip[1]; - VM_HANDLE_INTERRUPTS; - RESET_FRAME (nlocals); ip += label; @@ -709,8 +643,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, from); - VM_HANDLE_INTERRUPTS; - VM_ASSERT (from > 0, abort ()); nlocals = FRAME_LOCALS_COUNT (); @@ -789,8 +721,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, union scm_vm_stack_element *old_fp; scm_t_uint32 nlocals; - VM_HANDLE_INTERRUPTS; - UNPACK_24 (op, nlocals); if (nlocals) RESET_FRAME (nlocals); @@ -831,10 +761,23 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) - /* multiple values returned to continuation */ - RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); + { + SCM vals = scm_struct_ref (ret, SCM_INUM0); + long len = scm_ilength (vals); + ALLOC_FRAME (1 + len); + while (len--) + { + SP_SET (len, SCM_CAR (vals)); + vals = SCM_CDR (vals); + } + NEXT (1); + } else - RETURN_ONE_VALUE (ret); + { + ALLOC_FRAME (2); + SP_SET (0, ret); + NEXT (1); + } } /* foreign-call cif-idx:12 ptr-idx:12 @@ -864,10 +807,23 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) - /* multiple values returned to continuation */ - RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); + { + SCM vals = scm_struct_ref (ret, SCM_INUM0); + long len = scm_ilength (vals); + ALLOC_FRAME (1 + len); + while (len--) + { + SP_SET (len, SCM_CAR (vals)); + vals = SCM_CDR (vals); + } + NEXT (1); + } else - RETURN_ONE_VALUE (ret); + { + ALLOC_FRAME (2); + SP_SET (0, ret); + NEXT (1); + } } /* continuation-call contregs:24 @@ -936,8 +892,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, int i, list_idx, list_len, nlocals; SCM list; - VM_HANDLE_INTERRUPTS; - nlocals = FRAME_LOCALS_COUNT (); // At a minimum, there should be apply, f, and the list. VM_ASSERT (nlocals >= 3, abort ()); @@ -983,8 +937,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_dynstack *dynstack; int first; - VM_HANDLE_INTERRUPTS; - SYNC_IP (); dynstack = scm_dynstack_capture_all (&thread->dynstack); vm_cont = scm_i_vm_capture_stack (vp->stack_top, @@ -1407,8 +1359,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_int32 offset = op; offset >>= 8; /* Sign-extending shift. */ - if (offset <= 0) - VM_HANDLE_INTERRUPTS; NEXT (offset); } @@ -3704,8 +3654,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -3720,8 +3668,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -3926,7 +3872,18 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (183, handle_interrupts, "handle-interrupts", OP1 (X32)) { - VM_HANDLE_INTERRUPTS; + /* TODO: Invoke asyncs without trampolining out to C. That will + let us preempt computations via an asynchronous interrupt. */ + if (SCM_LIKELY (thread->block_asyncs == 0)) + { + SCM asyncs = scm_atomic_ref_scm (&thread->pending_asyncs); + if (SCM_UNLIKELY (!scm_is_null (asyncs))) + { + SYNC_IP (); + scm_async_tick (); + CACHE_SP (); + } + } NEXT (1); } @@ -4045,8 +4002,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, #undef POP_CONTINUATION_HOOK #undef PUSH_CONTINUATION_HOOK #undef RETURN -#undef RETURN_ONE_VALUE -#undef RETURN_VALUE_LIST #undef RUN_HOOK #undef RUN_HOOK0 #undef RUN_HOOK1