summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/gsubr.c7
-rw-r--r--libguile/intrinsics.h2
-rw-r--r--libguile/programs.c12
-rw-r--r--libguile/vm-engine.c2
-rw-r--r--libguile/vm.c135
-rw-r--r--module/system/vm/program.scm2
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 . ()))))))))