diff options
-rw-r--r-- | libguile/gsubr.c | 7 | ||||
-rw-r--r-- | libguile/intrinsics.h | 2 | ||||
-rw-r--r-- | libguile/programs.c | 12 | ||||
-rw-r--r-- | libguile/vm-engine.c | 2 | ||||
-rw-r--r-- | libguile/vm.c | 135 | ||||
-rw-r--r-- | module/system/vm/program.scm | 2 |
6 files changed, 97 insertions, 63 deletions
diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 227796e33..2384776e0 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -400,7 +400,7 @@ primitive_call_ip (const uint32_t *code) code -= 1; break; default: - abort (); + return 0; } } } @@ -410,8 +410,11 @@ static const uint32_t NOT_A_SUBR_CALL = 0xffffffff; static uint32_t primitive_subr_idx (const uint32_t *code) { + uint32_t word; uintptr_t call_ip = primitive_call_ip (code); - uint32_t word = ((uint32_t *) call_ip)[0]; + if (call_ip == 0) + return NOT_A_SUBR_CALL; + word = ((uint32_t *) call_ip)[0]; if ((word & 0xff) == scm_op_subr_call) { uint32_t idx = word >> 8; diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index b00471123..30e85c5fc 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -92,6 +92,7 @@ typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*); typedef void (*scm_t_ptr_scm_intrinsic) (SCM*, SCM); typedef SCM (*scm_t_scm_from_ptr_scm_intrinsic) (SCM*, SCM); typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM); +typedef uint32_t* scm_t_vcode_intrinsic; #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -167,6 +168,7 @@ typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM); M(ptr_scm, atomic_set_scm, "atomic-set-scm", ATOMIC_SET_SCM) \ M(scm_from_ptr_scm, atomic_swap_scm, "atomic-swap-scm", ATOMIC_SWAP_SCM) \ M(scm_from_ptr_scm_scm, atomic_compare_and_swap_scm, "atomic-compare-and-swap-scm", ATOMIC_COMPARE_AND_SWAP_SCM) \ + M(vcode, handle_interrupt_code, "%handle-interrupt-code", HANDLE_INTERRUPT_CODE) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/programs.c b/libguile/programs.c index 8d2b04e87..274114762 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -172,9 +172,12 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0, "") #define FUNC_NAME s_scm_primitive_call_ip { + uintptr_t ip; + SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P); - return scm_from_uintptr_t (scm_i_primitive_call_ip (prim)); + ip = scm_i_primitive_call_ip (prim); + return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F; } #undef FUNC_NAME @@ -312,11 +315,18 @@ try_parse_arity (SCM program, int *req, int *opt, int *rest) *opt = slots - min; *rest = 1; return 1; + case scm_op_shuffle_down: + case scm_op_abort: + *req = min - 1; + *opt = 0; + *rest = 1; + return 1; default: return 0; } case scm_op_continuation_call: case scm_op_compose_continuation: + case scm_op_shuffle_down: *req = 0; *opt = 0; *rest = 1; diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 2af02dcea..e8787eeeb 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2385,7 +2385,7 @@ VM_NAME (scm_thread *thread) SYNC_IP (); CALL_INTRINSIC (push_interrupt_frame, (thread, 0)); CACHE_SP (); - ip = (uint32_t *) vm_handle_interrupt_code; + ip = scm_vm_intrinsics.handle_interrupt_code; NEXT (0); } diff --git a/libguile/vm.c b/libguile/vm.c index ee22ad5c4..e14e5fe4a 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -300,60 +300,17 @@ vm_error_bad_instruction (uint32_t inst) static SCM vm_boot_continuation; -static SCM vm_builtin_apply; -static SCM vm_builtin_values; -static SCM vm_builtin_abort_to_prompt; -static SCM vm_builtin_call_with_values; -static SCM vm_builtin_call_with_current_continuation; + +#define DECLARE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ + static SCM vm_builtin_##builtin; \ + static uint32_t *vm_builtin_##builtin##_code; +FOR_EACH_VM_BUILTIN (DECLARE_BUILTIN) +#undef DECLARE_BUILTIN static const uint32_t vm_boot_continuation_code[] = { SCM_PACK_OP_24 (halt, 0) }; -static const uint32_t vm_builtin_apply_code[] = { - SCM_PACK_OP_24 (assert_nargs_ge, 3), - SCM_PACK_OP_12_12 (shuffle_down, 1, 0), - SCM_PACK_OP_24 (expand_apply_argument, 0), - SCM_PACK_OP_24 (tail_call, 0), -}; - -static const uint32_t vm_builtin_values_code[] = { - SCM_PACK_OP_12_12 (shuffle_down, 1, 0), - SCM_PACK_OP_24 (return_values, 0) -}; - -static const uint32_t vm_builtin_abort_to_prompt_code[] = { - SCM_PACK_OP_24 (assert_nargs_ge, 2), - SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */ - /* FIXME: Partial continuation should capture caller regs. */ - SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */ -}; - -static const uint32_t vm_builtin_call_with_values_code[] = { - SCM_PACK_OP_24 (assert_nargs_ee, 3), - SCM_PACK_OP_24 (alloc_frame, 8), - SCM_PACK_OP_12_12 (mov, 0, 6), - SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1), - SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2), - SCM_PACK_OP_12_12 (shuffle_down, 7, 1), - SCM_PACK_OP_24 (tail_call, 0) -}; - -static const uint32_t vm_builtin_call_with_current_continuation_code[] = { - SCM_PACK_OP_24 (assert_nargs_ee, 2), - SCM_PACK_OP_12_12 (mov, 1, 0), - SCM_PACK_OP_24 (capture_continuation, 0), - SCM_PACK_OP_24 (tail_call, 0) -}; - -static const uint32_t vm_handle_interrupt_code[] = { - SCM_PACK_OP_24 (alloc_frame, 4), - SCM_PACK_OP_12_12 (mov, 0, 3), - SCM_PACK_OP_24 (call, 3), SCM_PACK_OP_ARG_8_24 (0, 1), - SCM_PACK_OP_24 (return_from_interrupt, 0) -}; - - int scm_i_vm_is_boot_continuation_code (uint32_t *ip) { @@ -423,6 +380,75 @@ scm_init_vm_builtins (void) scm_vm_builtin_index_to_name); } +static uint32_t* +instrumented_code (const uint32_t *code, size_t byte_size) +{ + uint32_t *ret, *write; + ret = scm_i_alloc_primitive_code_with_instrumentation (byte_size / 4, &write); + memcpy (write, code, byte_size); + return ret; +} + +static void +define_vm_builtins (void) +{ + const uint32_t apply_code[] = { + SCM_PACK_OP_24 (assert_nargs_ge, 3), + SCM_PACK_OP_12_12 (shuffle_down, 1, 0), + SCM_PACK_OP_24 (expand_apply_argument, 0), + SCM_PACK_OP_24 (tail_call, 0), + }; + + const uint32_t values_code[] = { + SCM_PACK_OP_12_12 (shuffle_down, 1, 0), + SCM_PACK_OP_24 (return_values, 0) + }; + + const uint32_t abort_to_prompt_code[] = { + SCM_PACK_OP_24 (assert_nargs_ge, 2), + SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */ + /* FIXME: Partial continuation should capture caller regs. */ + SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */ + }; + + const uint32_t call_with_values_code[] = { + SCM_PACK_OP_24 (assert_nargs_ee, 3), + SCM_PACK_OP_24 (alloc_frame, 8), + SCM_PACK_OP_12_12 (mov, 0, 6), + SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1), + SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2), + SCM_PACK_OP_12_12 (shuffle_down, 7, 1), + SCM_PACK_OP_24 (tail_call, 0) + }; + + const uint32_t call_with_current_continuation_code[] = { + SCM_PACK_OP_24 (assert_nargs_ee, 2), + SCM_PACK_OP_12_12 (mov, 1, 0), + SCM_PACK_OP_24 (capture_continuation, 0), + SCM_PACK_OP_24 (tail_call, 0) + }; + + /* This one isn't exactly a builtin but we still handle it here. */ + const uint32_t handle_interrupt_code[] = { + SCM_PACK_OP_24 (alloc_frame, 4), + SCM_PACK_OP_12_12 (mov, 0, 3), + SCM_PACK_OP_24 (call, 3), SCM_PACK_OP_ARG_8_24 (0, 1), + SCM_PACK_OP_24 (return_from_interrupt, 0) + }; + +#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ + { \ + size_t sz = sizeof (builtin##_code); \ + vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \ + vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); \ + } + FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); +#undef INDEX_TO_NAME + + scm_vm_intrinsics.handle_interrupt_code = + instrumented_code (handle_interrupt_code, sizeof (handle_interrupt_code)); +} + SCM scm_i_call_with_current_continuation (SCM proc) { @@ -1701,11 +1727,7 @@ scm_init_vm_builtin_properties (void) #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \ scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \ - scm_sym_##builtin); \ - scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \ - SCM_I_MAKINUM (req), \ - SCM_I_MAKINUM (opt), \ - scm_from_bool (rest)); + scm_sym_##builtin); FOR_EACH_VM_BUILTIN (INIT_BUILTIN); #undef INIT_BUILTIN } @@ -1748,10 +1770,7 @@ scm_bootstrap_vm (void) (SCM_CELL_WORD_0 (vm_boot_continuation) | SCM_F_PROGRAM_IS_BOOT)); -#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ - vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); - FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); -#undef DEFINE_BUILTIN + define_vm_builtins (); } void diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 4f6d9abcd..e5dbcc089 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -204,7 +204,7 @@ of integers." ((nreq nopt rest?) (let ((start (primitive-call-ip prog))) ;; Assume that there is only one IP for the call. - (and (or (not ip) (= start ip)) + (and (or (not ip) (and start (= start ip))) (arity->arguments-alist prog (list 0 0 nreq nopt rest? '(#f . ())))))))) |