summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/instructions.c12
-rw-r--r--libguile/vm-engine.c746
-rw-r--r--libguile/vm.c9
-rw-r--r--module/Makefile.am3
-rw-r--r--module/system/vm/assembler.scm40
-rw-r--r--module/system/vm/disassembler.scm17
-rw-r--r--test-suite/tests/rtl.test65
7 files changed, 353 insertions, 539 deletions
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 9e7e5193c..43937d76a 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -67,7 +67,9 @@ SCM_SYMBOL (sym_bang, "!");
M(X8_U12_U12) \
M(X8_L24) \
M(B1_X7_L24) \
- M(B1_U7_L24)
+ M(B1_U7_L24) \
+ M(B1_X7_U24) \
+ M(B1_X31)
#define TYPE_WIDTH 5
@@ -105,6 +107,8 @@ static SCM word_type_symbols[] =
(OP (0, type0) | OP (1, type1) | OP (2, type2))
#define OP4(type0, type1, type2, type3) \
(OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3))
+#define OP5(type0, type1, type2, type3, type4) \
+ (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3) | OP (4, type4))
#define OP_DST (1 << (TYPE_WIDTH * 5))
@@ -254,7 +258,9 @@ SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0,
/* Format: (name opcode word0 word1 ...) */
- if (WORD_TYPE (3, meta))
+ if (WORD_TYPE (4, meta))
+ len = 5;
+ else if (WORD_TYPE (3, meta))
len = 4;
else if (WORD_TYPE (2, meta))
len = 3;
@@ -267,6 +273,8 @@ SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0,
switch (len)
{
+ case 5:
+ tail = scm_cons (word_type_symbols[WORD_TYPE (4, meta)], tail);
case 4:
tail = scm_cons (word_type_symbols[WORD_TYPE (3, meta)], tail);
case 3:
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 613c638e4..369bb793a 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -641,9 +641,14 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
SCM *sp = SCM_FRAME_LOWER_ADDRESS (fp); \
VM_HANDLE_INTERRUPTS; \
ip = SCM_FRAME_RTL_RETURN_ADDRESS (fp); \
- vp->sp = sp; \
fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
- *sp = val; \
+ /* Clear frame. */ \
+ sp[0] = SCM_BOOL_F; \
+ sp[1] = SCM_BOOL_F; \
+ sp[2] = SCM_BOOL_F; \
+ /* Leave proc. */ \
+ sp[4] = val; \
+ vp->sp = sp + 4; \
POP_CONTINUATION_HOOK (sp, 1); \
NEXT (0); \
} while (0)
@@ -715,7 +720,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
{ \
scm_t_signed_bits x_bits = SCM_UNPACK (x); \
scm_t_signed_bits y_bits = SCM_UNPACK (y); \
- if (x_bits crel y_bits) \
+ if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
{ \
scm_t_int32 offset = ip[1]; \
offset >>= 8; /* Sign-extending shift. */ \
@@ -727,8 +732,10 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
} \
else \
{ \
+ SCM res; \
SYNC_IP (); \
- if (scm_is_true (srel (x, y))) \
+ res = srel (x, y); \
+ if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
{ \
scm_t_int32 offset = ip[1]; \
offset >>= 8; /* Sign-extending shift. */ \
@@ -877,13 +884,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
base[2] = SCM_PACK (ip); /* ra */
base[3] = rtl_boot_continuation;
fp = &base[4];
- ip = rtl_boot_single_value_continuation_code;
- if (ip - 1 != rtl_boot_multiple_value_continuation_code)
- abort();
+ ip = (scm_t_uint32 *) rtl_boot_continuation_code;
/* MV-call frame, function & arguments */
base[4] = SCM_PACK (fp); /* dynamic link */
- base[5] = SCM_PACK (ip - 1); /* in RTL programs, MVRA precedes RA by one */
+ base[5] = SCM_PACK (ip); /* in RTL programs, MVRA same as RA */
base[6] = SCM_PACK (ip); /* ra */
base[7] = program;
fp = vp->fp = &base[8];
@@ -945,87 +950,64 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
/* halt _:24
*
- * Bring the VM to a halt, returning the single value from slot 1.
+ * Bring the VM to a halt, returning all the values from the stack.
*/
VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
{
- SCM ret = LOCAL_REF (1);
-
- vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
- vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- return ret;
- }
-
- /* halt/values _:24
- *
- * Bring the VM to a halt, returning all the values from the MV stack.
- */
- VM_DEFINE_OP (1, halt_values, "halt/values", OP1 (U8_X24))
- {
- scm_t_ptrdiff n;
- SCM ret = SCM_EOL;
+ scm_t_uint32 nvals = FRAME_LOCALS_COUNT() - 5;
+ SCM ret;
- SYNC_BEFORE_GC();
+ /* Boot closure in r0, empty frame in r1/r2/r3, proc in r4, values from r5. */
- /* Boot closure in r0, empty stack from r1 to r4, values from r5. */
- for (n = FRAME_LOCALS_COUNT () - 1; n >= 5; n--)
- ret = scm_cons (LOCAL_REF (n), ret);
+ if (nvals == 1)
+ ret = LOCAL_REF (5);
+ else
+ {
+ scm_t_uint32 n;
+ ret = SCM_EOL;
+ SYNC_BEFORE_GC();
+ for (n = nvals; n > 0; n--)
+ ret = scm_cons (LOCAL_REF (5 + n), ret);
+ ret = scm_values (ret);
+ }
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
- return scm_values (ret);
- }
-
- /* push-frame from:24 _:8 nargs:24
- *
- * Push a frame for a new procedure call starting at FROM.
- * Reserve stack space for NARGS values in the new frame, including
- * the procedure.
- */
- VM_DEFINE_OP (2, push_frame, "push-frame", OP2 (U8_U24, X8_U24))
- {
- scm_t_uint32 from, nargs, new_size, n;
-
- SCM_UNPACK_RTL_24 (op, from);
- SCM_UNPACK_RTL_24 (ip[1], nargs);
-
- new_size = from + 3 + nargs;
- ALLOC_FRAME (new_size);
-
- /* FIXME: Elide this initialization? */
- for (n = from; n < new_size; n++)
- LOCAL_SET (n, SCM_UNDEFINED);
-
- NEXT (2);
+ return ret;
}
- /* call from:24
+ /* call proc:24 _:8 nlocals:24
*
- * Call a procedure. Links a call frame at FROM, saving the return
- * address and the fp.
+ * Call a procedure. PROC is the local corresponding to a procedure.
+ * The three values below PROC will be overwritten by the saved call
+ * frame data. The new frame will have space for NLOCALS locals: one
+ * for the procedure, and the rest for the arguments which should
+ * already have been pushed on.
*
- * The MVRA of the new frame is set to point to the next instruction
- * after the end of the `call' instruction. The word following that
- * is the RA.
+ * When the call returns, execution proceeds with the next
+ * instruction. There may be any number of values on the return
+ * stack; the precise number can be had by subtracting the address of
+ * PROC from the post-call SP.
*/
- VM_DEFINE_OP (3, call, "call", OP1 (U8_U24))
+ VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24))
{
- scm_t_uint32 from;
+ scm_t_uint32 proc, nlocals;
SCM *old_fp = fp;
- SCM_UNPACK_RTL_24 (op, from);
+ SCM_UNPACK_RTL_24 (op, proc);
+ SCM_UNPACK_RTL_24 (ip[1], nlocals);
VM_HANDLE_INTERRUPTS;
- fp = vp->fp = old_fp + from + 3;
+ fp = vp->fp = old_fp + proc;
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 1);
+ SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 2);
+ RESET_FRAME (nlocals);
+
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
@@ -1036,32 +1018,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (0);
}
- /* call/values from:24 _:8 proc:24
- *
- * Call a procedure, with the values already pushed above a call frame
- * at FROM. This instruction is used to handle MV returns in the case
- * that we can't inline the handler.
+ /* tail-call nlocals:24
*
- * As with `call', the next instruction after the call/values will be
- * the MVRA, and the word after that instruction is the RA.
+ * Tail-call a procedure. Requires that the procedure and all of the
+ * arguments have already been shuffled into position.
*/
- VM_DEFINE_OP (4, call_values, "call/values", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24))
{
- scm_t_uint32 from, proc;
- SCM *old_fp = fp;
-
- SCM_UNPACK_RTL_24 (op, from);
- SCM_UNPACK_RTL_24 (ip[1], proc);
+ scm_t_uint32 nlocals;
+
+ SCM_UNPACK_RTL_24 (op, nlocals);
VM_HANDLE_INTERRUPTS;
- fp = vp->fp = old_fp + from + 4;
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
- SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3);
- fp[-1] = old_fp[proc - 1];
-
- PUSH_CONTINUATION_HOOK ();
+ RESET_FRAME (nlocals);
APPLY_HOOK ();
if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
@@ -1071,39 +1041,46 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (0);
}
- /* tail-call nargs:24 _:8 proc:24
+ /* receive dst:12 proc:12 _:8 nlocals:24
*
- * Tail-call a procedure. Requires that all of the arguments have
- * already been shuffled into position.
+ * Receive a single return value from a call whose procedure was in
+ * PROC, asserting that the call actually returned at least one
+ * value. Afterwards, resets the frame to NLOCALS locals.
*/
- VM_DEFINE_OP (5, tail_call, "tail-call", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (3, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
- scm_t_uint32 nargs, proc;
-
- SCM_UNPACK_RTL_24 (op, nargs);
- SCM_UNPACK_RTL_24 (ip[1], proc);
-
- VM_HANDLE_INTERRUPTS;
-
- fp[-1] = LOCAL_REF (proc);
- /* No need to check for overflow, as the compiler has already
- ensured that this frame has enough space. */
- RESET_FRAME (nargs + 1);
-
- APPLY_HOOK ();
-
- if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
- goto apply;
+ scm_t_uint16 dst, proc;
+ scm_t_uint32 nlocals;
+ SCM_UNPACK_RTL_12_12 (op, dst, proc);
+ SCM_UNPACK_RTL_24 (ip[1], nlocals);
+ VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ());
+ LOCAL_SET (dst, LOCAL_REF (proc + 1));
+ RESET_FRAME (nlocals);
+ NEXT (2);
+ }
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
- NEXT (0);
+ /* receive-values proc:24 _:8 nvalues:24
+ *
+ * Receive a return of multiple values from a call whose procedure was
+ * in PROC. If fewer than NVALUES values were returned, signal an
+ * error. After receive-values has run, the values can be copied down
+ * via `mov'.
+ */
+ VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, X8_U24))
+ {
+ scm_t_uint32 proc, nvalues;
+ SCM_UNPACK_RTL_24 (op, proc);
+ SCM_UNPACK_RTL_24 (ip[1], nvalues);
+ VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
+ vm_error_not_enough_values ());
+ NEXT (2);
}
/* return src:24
*
* Return a value.
*/
- VM_DEFINE_OP (6, return, "return", OP1 (U8_U24))
+ VM_DEFINE_OP (5, return, "return", OP1 (U8_U24))
{
scm_t_uint32 src;
SCM_UNPACK_RTL_24 (op, src);
@@ -1114,16 +1091,30 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Return a number of values from a call frame. This opcode
* corresponds to an application of `values' in tail position. As
- * with tail calls, we expect that the NVALUES values have already
- * been shuffled down to a contiguous array starting at slot 0.
+ * with tail calls, we expect that the values have already been
+ * shuffled down to a contiguous array starting at slot 1.
*/
- VM_DEFINE_OP (7, return_values, "return/values", OP1 (U8_U24))
+ VM_DEFINE_OP (6, return_values, "return-values", OP1 (U8_U24))
{
- scm_t_uint32 nargs;
- SCM_UNPACK_RTL_24 (op, nargs);
- RESET_FRAME (nargs + 1);
- fp[-1] = rtl_values;
- goto op_values;
+ scm_t_uint32 nvalues;
+ SCM *base = fp;
+
+ SCM_UNPACK_RTL_24 (op, nvalues);
+
+ RESET_FRAME (nvalues + 1);
+
+ VM_HANDLE_INTERRUPTS;
+ ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp);
+ fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
+
+ /* Clear stack frame. */
+ base[-2] = SCM_BOOL_F;
+ base[-3] = SCM_BOOL_F;
+ base[-4] = SCM_BOOL_F;
+
+ POP_CONTINUATION_HOOK (base, nvalues);
+
+ NEXT (0);
}
@@ -1140,7 +1131,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* calling frame. This instruction is part of the trampolines
* created in gsubr.c, and is not generated by the compiler.
*/
- VM_DEFINE_OP (8, subr_call, "subr-call", OP1 (U8_U24))
+ VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
{
scm_t_uint32 ptr_idx;
SCM pointer, ret;
@@ -1210,7 +1201,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* part of the trampolines created by the FFI, and is not generated by
* the compiler.
*/
- VM_DEFINE_OP (9, foreign_call, "foreign-call", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
{
scm_t_uint16 cif_idx, ptr_idx;
SCM closure, cif, pointer, ret;
@@ -1244,7 +1235,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* the implementation of undelimited continuations, and is not
* generated by the compiler.
*/
- VM_DEFINE_OP (10, continuation_call, "continuation-call", OP1 (U8_U24))
+ VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
{
SCM contregs;
scm_t_uint32 contregs_idx;
@@ -1273,7 +1264,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* instruction is part of the implementation of partial continuations,
* and is not generated by the compiler.
*/
- VM_DEFINE_OP (11, compose_continuation, "compose-continuation", OP1 (U8_U24))
+ VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
{
SCM vmcont;
scm_t_uint32 cont_idx;
@@ -1297,7 +1288,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* arguments. This instruction is part of the implementation of
* `apply', and is not generated by the compiler.
*/
- VM_DEFINE_OP (12, apply, "apply", OP1 (U8_X24))
+ VM_DEFINE_OP (11, apply, "apply", OP1 (U8_X24))
{
int i, list_idx, list_len, nargs;
SCM list;
@@ -1341,7 +1332,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* local slot 0 to it. This instruction is part of the implementation
* of `call/cc', and is not generated by the compiler.
*/
- VM_DEFINE_OP (13, call_cc, "call/cc", OP1 (U8_X24))
+ VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24))
#if 0
{
SCM vm_cont, cont;
@@ -1376,37 +1367,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
abort();
#endif
- /* values _:24
- *
- * Return all values on the stack to the current continuation.
- * This instruction is part of the implementation of
- * `values', and is not generated by the compiler.
- */
- VM_DEFINE_OP (14, values, "values", OP1 (U8_X24))
- {
- SCM *base = fp;
-#if VM_USE_HOOKS
- int nargs = FRAME_LOCALS_COUNT () - 1;
-#endif
-
- /* We don't do much; it's the caller that's responsible for
- shuffling values and resetting the stack. */
-
- VM_HANDLE_INTERRUPTS;
- ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp);
- fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- /* Clear stack frame. */
- base[-1] = SCM_BOOL_F;
- base[-2] = SCM_BOOL_F;
- base[-3] = SCM_BOOL_F;
- base[-4] = SCM_BOOL_F;
-
- POP_CONTINUATION_HOOK (base, nargs);
-
- NEXT (0);
- }
-
@@ -1422,15 +1382,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
* the current instruction pointer.
*/
- VM_DEFINE_OP (15, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
{
BR_NARGS (!=);
}
- VM_DEFINE_OP (16, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (<);
}
- VM_DEFINE_OP (17, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (>);
}
@@ -1442,7 +1402,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the number of actual arguments is not ==, >=, or <= EXPECTED,
* respectively, signal an error.
*/
- VM_DEFINE_OP (18, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
+ VM_DEFINE_OP (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1450,7 +1410,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (19, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
+ VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1458,7 +1418,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (20, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
+ VM_DEFINE_OP (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1467,13 +1427,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
- /* reserve-locals nlocals:24
+ /* alloc-frame nlocals:24
*
* Ensure that there is space on the stack for NLOCALS local variables,
* setting them all to SCM_UNDEFINED, except those nargs values that
* were passed as arguments and procedure.
*/
- VM_DEFINE_OP (21, reserve_locals, "reserve-locals", OP1 (U8_U24))
+ VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24))
{
scm_t_uint32 nlocals, nargs;
SCM_UNPACK_RTL_24 (op, nlocals);
@@ -1486,12 +1446,26 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
+ /* reset-frame nlocals:24
+ *
+ * Like alloc-frame, but doesn't check that the stack is big enough.
+ * Used to reset the frame size to something less than the size that
+ * was previously set via alloc-frame.
+ */
+ VM_DEFINE_OP (20, reset_frame, "reset-frame", OP1 (U8_U24))
+ {
+ scm_t_uint32 nlocals;
+ SCM_UNPACK_RTL_24 (op, nlocals);
+ RESET_FRAME (nlocals);
+ NEXT (1);
+ }
+
/* assert-nargs-ee/locals expected:12 nlocals:12
*
* Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
* number of locals reserved is EXPECTED + NLOCALS.
*/
- VM_DEFINE_OP (22, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
{
scm_t_uint16 expected, nlocals;
SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
@@ -1516,7 +1490,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* A macro-mega-instruction.
*/
- VM_DEFINE_OP (23, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
+ VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
{
scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
scm_t_int32 kw_offset;
@@ -1602,7 +1576,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Collect any arguments at or above DST into a list, and store that
* list at DST.
*/
- VM_DEFINE_OP (24, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst, nargs;
SCM rest = SCM_EOL;
@@ -1623,22 +1597,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
- /* drop-values nlocals:24
- *
- * Reset the stack pointer to only have space for NLOCALS values.
- * Used after extracting values from an MV return.
- */
- VM_DEFINE_OP (25, drop_values, "drop-values", OP1 (U8_U24))
- {
- scm_t_bits nlocals;
-
- SCM_UNPACK_RTL_24 (op, nlocals);
-
- RESET_FRAME (nlocals);
-
- NEXT (1);
- }
-
@@ -1651,7 +1609,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Add OFFSET, a signed 24-bit number, to the current instruction
* pointer.
*/
- VM_DEFINE_OP (26, br, "br", OP1 (U8_L24))
+ VM_DEFINE_OP (24, br, "br", OP1 (U8_L24))
{
scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */
@@ -1663,7 +1621,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in TEST is true for the purposes of Scheme, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (27, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_true (x));
}
@@ -1673,7 +1631,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
* signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (28, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_null (x));
}
@@ -1683,7 +1641,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (29, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_lisp_false (x));
}
@@ -1693,7 +1651,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (30, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_pair (x));
}
@@ -1703,7 +1661,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in TEST is a struct, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (31, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_STRUCTP (x));
}
@@ -1713,7 +1671,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in TEST is a char, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (32, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_CHARP (x));
}
@@ -1723,7 +1681,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in TEST has the TC7 given in the second word, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (33, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
+ VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
{
BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
}
@@ -1733,7 +1691,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in A is eq? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (34, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y, scm_is_eq (x, y));
}
@@ -1743,7 +1701,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in A is eqv? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (35, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1751,13 +1709,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
&& scm_is_true (scm_eqv_p (x, y))));
}
+ // FIXME: remove, have compiler inline eqv test instead
/* br-if-equal a:12 b:12 invert:1 _:7 offset:24
*
* If the value in A is equal? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
// FIXME: should sync_ip before calling out?
- VM_DEFINE_OP (36, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1765,12 +1724,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
&& scm_is_true (scm_equal_p (x, y))));
}
- /* br-if-= a:12 b:12 _:8 offset:24
+ /* br-if-= a:12 b:12 invert:1 _:7 offset:24
*
* If the value in A is = to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (37, br_if_ee, "br-if-=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (==, scm_num_eq_p);
}
@@ -1780,7 +1739,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in A is < to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (38, br_if_lt, "br-if-<", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (<, scm_less_p);
}
@@ -1790,31 +1749,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* If the value in A is <= to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (39, br_if_le, "br-if-<=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (<=, scm_leq_p);
}
- /* br-if-> a:12 b:12 _:8 offset:24
- *
- * If the value in A is > to the value in B, add OFFSET, a signed
- * 24-bit number, to the current instruction pointer.
- */
- VM_DEFINE_OP (40, br_if_gt, "br-if->", OP2 (U8_U12_U12, X8_L24))
- {
- BR_ARITHMETIC (>, scm_gr_p);
- }
-
- /* br-if->= a:12 b:12 _:8 offset:24
- *
- * If the value in A is >= to the value in B, add OFFSET, a signed
- * 24-bit number, to the current instruction pointer.
- */
- VM_DEFINE_OP (41, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
- {
- BR_ARITHMETIC (>=, scm_geq_p);
- }
-
@@ -1826,7 +1765,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (42, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst;
scm_t_uint16 src;
@@ -1841,7 +1780,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (43, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ VM_DEFINE_OP (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 src;
@@ -1857,7 +1796,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Create a new variable holding SRC, and place it in DST.
*/
- VM_DEFINE_OP (44, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (40, box, "box", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1865,40 +1804,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
- /* empty-box dst:24
- *
- * Create a new unbound variable, and place it in DST. Used in the
- * general implementation of `letrec', in those cases that fix-letrec
- * fails to fix.
- */
- VM_DEFINE_OP (45, empty_box, "empty-box", OP1 (U8_U24) | OP_DST)
- {
- scm_t_uint32 dst;
- SCM_UNPACK_RTL_24 (op, dst);
- LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
- NEXT (1);
- }
-
/* box-ref dst:12 src:12
*
* Unpack the variable at SRC into DST, asserting that the variable is
* actually bound.
*/
- VM_DEFINE_OP (46, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
SCM_UNPACK_RTL_12_12 (op, dst, src);
var = LOCAL_REF (src);
VM_ASSERT (SCM_VARIABLEP (var), abort ());
- if (SCM_UNLIKELY (!VARIABLE_BOUNDP (var)))
- {
- SCM var_name;
- /* Attempt to provide the variable name in the error message. */
- SYNC_IP ();
- var_name = scm_module_reverse_lookup (scm_current_module (), var);
- vm_error_unbound (SCM_FRAME_PROGRAM (fp), scm_is_true (var_name) ? var_name : var);
- }
+ VM_ASSERT (VARIABLE_BOUNDP (var),
+ vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
LOCAL_SET (dst, VARIABLE_REF (var));
NEXT (1);
}
@@ -1907,7 +1826,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Set the contents of the variable at DST to SET.
*/
- VM_DEFINE_OP (47, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1925,7 +1844,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* signed 32-bit integer. Space for NFREE free variables will be
* allocated.
*/
- VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
+ VM_DEFINE_OP (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
@@ -1949,7 +1868,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Load free variable IDX from the closure SRC into local slot DST.
*/
- VM_DEFINE_OP (49, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
+ VM_DEFINE_OP (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
@@ -1964,7 +1883,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Set free variable IDX from the closure DST to SRC.
*/
- VM_DEFINE_OP (50, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
+ VM_DEFINE_OP (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
@@ -1987,7 +1906,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (51, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
+ VM_DEFINE_OP (46, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2002,7 +1921,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (52, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
+ VM_DEFINE_OP (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2017,7 +1936,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Make an immediate with HIGH-BITS and LOW-BITS.
*/
- VM_DEFINE_OP (53, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
+ VM_DEFINE_OP (48, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2048,7 +1967,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Whether the object is mutable or immutable depends on where it was
* allocated by the compiler, and loaded by the loader.
*/
- VM_DEFINE_OP (54, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
+ VM_DEFINE_OP (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2077,7 +1996,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* that the compiler is unable to statically allocate, like symbols.
* These values would be initialized when the object file loads.
*/
- VM_DEFINE_OP (55, static_ref, "static-ref", OP2 (U8_U24, S32))
+ VM_DEFINE_OP (50, static_ref, "static-ref", OP2 (U8_U24, S32))
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2100,7 +2019,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Store a SCM value into memory, OFFSET 32-bit words away from the
* current instruction pointer. OFFSET is a signed value.
*/
- VM_DEFINE_OP (56, static_set, "static-set!", OP2 (U8_U24, LO32))
+ VM_DEFINE_OP (51, static_set, "static-set!", OP2 (U8_U24, LO32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2122,7 +2041,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* words away from the current instruction pointer. OFFSET is a
* signed value.
*/
- VM_DEFINE_OP (57, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
+ VM_DEFINE_OP (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2164,26 +2083,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
(lambda () (if (foo) a b))
- Although one can use resolve and box-ref, the toplevel-ref and
- toplevel-set! instructions are better for references.
+ The toplevel-box instruction is equivalent to "resolve", but
+ caches the resulting variable in statically allocated memory.
3. A reference to an identifier with respect to a particular
module. This can happen for primitive references, and
- references residualized by macro expansions. These can be
- cached or not, depending on whether they are in a lambda or not.
-
- (@ (foo bar) a)
- (@@ (foo bar) a)
-
- For these, one can use resolve-module, resolve, and the box
- interface, though there is also module-ref as a shortcut.
+ references residualized by macro expansions. These can always
+ be cached. Use module-box for these.
*/
/* current-module dst:24
*
* Store the current module in DST.
*/
- VM_DEFINE_OP (58, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
@@ -2195,42 +2108,28 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
- /* resolve dst:8 mod:8 sym:8
+ /* resolve dst:24 bound?:1 _:7 sym:24
*
- * Resolve SYM in MOD, and place the resulting variable in DST.
- */
- VM_DEFINE_OP (59, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
- {
- scm_t_uint8 dst, mod, sym;
-
- SCM_UNPACK_RTL_8_8_8 (op, dst, mod, sym);
-
- SYNC_IP ();
- LOCAL_SET (dst, scm_module_lookup (LOCAL_REF (mod), LOCAL_REF (sym)));
-
- NEXT (1);
- }
-
- /* resolve-module dst:8 name:8 public:8
- *
- * Resolve a module with name NAME, placing it in DST. If PUBLIC is
- * nonzero, resolve the public interface, otherwise use the private
- * interface.
+ * Resolve SYM in the current module, and place the resulting variable
+ * in DST.
*/
- VM_DEFINE_OP (60, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
{
- scm_t_uint8 dst, name, public;
- SCM mod;
+ scm_t_uint32 dst;
+ scm_t_uint32 sym;
+ SCM var;
- SCM_UNPACK_RTL_8_8_8 (op, dst, name, public);
+ SCM_UNPACK_RTL_24 (op, dst);
+ SCM_UNPACK_RTL_24 (ip[1], sym);
SYNC_IP ();
- mod = scm_resolve_module (LOCAL_REF (name));
- if (public)
- mod = scm_module_public_interface (mod);
- LOCAL_SET (dst, mod);
+ var = scm_lookup (LOCAL_REF (sym));
+ if (ip[1] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var),
+ vm_error_unbound (fp[-1], LOCAL_REF (sym)));
+ LOCAL_SET (dst, var);
- NEXT (1);
+ NEXT (2);
}
/* define sym:12 val:12
@@ -2238,7 +2137,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Look up a binding for SYM in the current module, creating it if
* necessary. Set its value to VAL.
*/
- VM_DEFINE_OP (61, define, "define", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (55, define, "define", OP1 (U8_U12_U12))
{
scm_t_uint16 sym, val;
SCM_UNPACK_RTL_12_12 (op, sym, val);
@@ -2247,26 +2146,26 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
- /* toplevel-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32
+ /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
*
* Load a SCM value. The SCM value will be fetched from memory,
* VAR-OFFSET 32-bit words away from the current instruction pointer.
- * VAR-OFFSET is a signed value. Up to here, toplevel-ref is like
+ * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
* static-ref.
*
- * Then, if the loaded value is a variable, the value of the variable
- * is placed in DST, and control flow continues.
+ * Then, if the loaded value is a variable, it is placed in DST, and control
+ * flow continues.
*
* Otherwise, we have to resolve the variable. In that case we load
* the module from MOD-OFFSET, just as we loaded the variable.
* Usually the module gets set when the closure is created. The name
* is an offset to a symbol.
*
- * We use the module and the string to resolve the variable, raising
- * an error if it is unbound, unbox it into DST, and cache the
- * resolved variable so that we will hit the cache next time.
+ * We use the module and the symbol to resolve the variable, placing it in
+ * DST, and caching the resolved variable so that we will hit the cache next
+ * time.
*/
- VM_DEFINE_OP (62, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32) | OP_DST)
+ VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2298,66 +2197,22 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
sym = *((SCM *) sym_loc);
var = scm_module_lookup (mod, sym);
- VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
+ if (ip[4] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
*var_loc = var;
}
- LOCAL_SET (dst, VARIABLE_REF (var));
- NEXT (4);
+ LOCAL_SET (dst, var);
+ NEXT (5);
}
- /* toplevel-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
+ /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
*
- * Set a top-level variable from a variable cache cell. The variable
- * is resolved as in toplevel-ref.
- */
- VM_DEFINE_OP (63, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
- {
- scm_t_uint32 src;
- scm_t_int32 var_offset;
- scm_t_uint32* var_loc_u32;
- SCM *var_loc;
- SCM var;
-
- SCM_UNPACK_RTL_24 (op, src);
- var_offset = ip[1];
- var_loc_u32 = ip + var_offset;
- VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
- var_loc = (SCM *) var_loc_u32;
- var = *var_loc;
-
- if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
- {
- SCM mod, sym;
- scm_t_int32 mod_offset = ip[2]; /* signed */
- scm_t_int32 sym_offset = ip[3]; /* signed */
- scm_t_uint32 *mod_loc = ip + mod_offset;
- scm_t_uint32 *sym_loc = ip + sym_offset;
-
- SYNC_IP ();
-
- VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort());
- VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
-
- mod = *((SCM *) mod_loc);
- sym = *((SCM *) sym_loc);
-
- var = scm_module_lookup (mod, sym);
-
- *var_loc = var;
- }
-
- VARIABLE_SET (var, LOCAL_REF (src));
- NEXT (4);
- }
-
- /* module-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32
- *
- * Like toplevel-ref, except MOD-OFFSET points at the name of a module
+ * Like toplevel-box, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (64, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) | OP_DST)
+ VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2393,61 +2248,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
else
var = scm_private_lookup (SCM_CDR (modname), sym);
- VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
-
- *var_loc = var;
- }
-
- LOCAL_SET (dst, VARIABLE_REF (var));
- NEXT (4);
- }
-
- /* module-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
- *
- * Like toplevel-set!, except MOD-OFFSET points at the name of a module
- * instead of the module itself.
- */
- VM_DEFINE_OP (65, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
- {
- scm_t_uint32 src;
- scm_t_int32 var_offset;
- scm_t_uint32* var_loc_u32;
- SCM *var_loc;
- SCM var;
-
- SCM_UNPACK_RTL_24 (op, src);
- var_offset = ip[1];
- var_loc_u32 = ip + var_offset;
- VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
- var_loc = (SCM *) var_loc_u32;
- var = *var_loc;
-
- if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
- {
- SCM modname, sym;
- scm_t_int32 modname_offset = ip[2]; /* signed */
- scm_t_int32 sym_offset = ip[3]; /* signed */
- scm_t_uint32 *modname_words = ip + modname_offset;
- scm_t_uint32 *sym_loc = ip + sym_offset;
-
- SYNC_IP ();
-
- VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort());
- VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
-
- modname = SCM_PACK ((scm_t_bits) modname_words);
- sym = *((SCM *) sym_loc);
-
- if (scm_is_true (SCM_CAR (modname)))
- var = scm_public_lookup (SCM_CDR (modname), sym);
- else
- var = scm_private_lookup (SCM_CDR (modname), sym);
+ if (ip[4] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
*var_loc = var;
}
- VARIABLE_SET (var, LOCAL_REF (src));
- NEXT (4);
+ LOCAL_SET (dst, var);
+ NEXT (5);
}
@@ -2462,7 +2270,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* handler at HANDLER-OFFSET words from the current IP. The handler
* will expect a multiple-value return.
*/
- VM_DEFINE_OP (66, prompt, "prompt", OP2 (U8_U24, U8_L24))
+ VM_DEFINE_OP (58, prompt, "prompt", OP2 (U8_U24, U8_L24))
#if 0
{
scm_t_uint32 tag;
@@ -2494,7 +2302,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* the compiler should have inserted checks that they wind and unwind
* procs are thunks, if it could not prove that to be the case.
*/
- VM_DEFINE_OP (67, wind, "wind", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (59, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
@@ -2503,12 +2311,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
- /* abort tag:24 _:8 from:24
+ /* abort tag:24 _:8 proc:24
*
* Return a number of values to a prompt handler. The values are
- * expected in a frame pushed on at FROM.
+ * expected in a frame pushed on at PROC.
*/
- VM_DEFINE_OP (68, abort, "abort", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24))
#if 0
{
scm_t_uint32 tag, from, nvalues;
@@ -2534,7 +2342,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* A normal exit from the dynamic extent of an expression. Pop the top
* entry off of the dynamic stack.
*/
- VM_DEFINE_OP (69, unwind, "unwind", OP1 (U8_X24))
+ VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (&current_thread->dynstack);
NEXT (1);
@@ -2546,7 +2354,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* allocated in a continguous range on the stack, starting from
* FLUID-BASE. The values do not have this restriction.
*/
- VM_DEFINE_OP (70, push_fluid, "push-fluid", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (62, push_fluid, "push-fluid", OP1 (U8_U12_U12))
{
scm_t_uint32 fluid, value;
@@ -2563,7 +2371,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Leave the dynamic extent of a with-fluids expression, restoring the
* fluids to their previous values.
*/
- VM_DEFINE_OP (71, pop_fluid, "pop-fluid", OP1 (U8_X24))
+ VM_DEFINE_OP (63, pop_fluid, "pop-fluid", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluid (&current_thread->dynstack,
@@ -2575,7 +2383,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Reference the fluid in SRC, and place the value in DST.
*/
- VM_DEFINE_OP (72, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
@@ -2608,7 +2416,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Set the value of the fluid in DST to the value in SRC.
*/
- VM_DEFINE_OP (73, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (65, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
@@ -2641,7 +2449,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store the length of the string in SRC in DST.
*/
- VM_DEFINE_OP (74, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -2658,7 +2466,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Fetch the character at position IDX in the string in SRC, and store
* it in DST.
*/
- VM_DEFINE_OP (75, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -2680,7 +2488,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Parse a string in SRC to a number, and store in DST.
*/
- VM_DEFINE_OP (76, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (68, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
@@ -2696,7 +2504,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Parse a string in SRC to a symbol, and store in DST.
*/
- VM_DEFINE_OP (77, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
@@ -2710,7 +2518,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Make a keyword from the symbol in SRC, and store it in DST.
*/
- VM_DEFINE_OP (78, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -2729,7 +2537,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Cons CAR and CDR, and store the result in DST.
*/
- VM_DEFINE_OP (79, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
@@ -2739,7 +2547,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (80, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
@@ -2750,7 +2558,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (81, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
@@ -2761,7 +2569,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (82, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2777,7 +2585,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (83, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2800,7 +2608,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Add A to B, and place the result in DST.
*/
- VM_DEFINE_OP (84, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
@@ -2809,7 +2617,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Add 1 to the value in SRC, and place the result in DST.
*/
- VM_DEFINE_OP (85, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2834,7 +2642,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Subtract B from A, and place the result in DST.
*/
- VM_DEFINE_OP (86, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
@@ -2843,7 +2651,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Subtract 1 from SRC, and place the result in DST.
*/
- VM_DEFINE_OP (87, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2868,7 +2676,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Multiply A and B, and place the result in DST.
*/
- VM_DEFINE_OP (88, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2879,7 +2687,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Divide A by B, and place the result in DST.
*/
- VM_DEFINE_OP (89, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2890,7 +2698,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Divide A by B, and place the quotient in DST.
*/
- VM_DEFINE_OP (90, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2901,7 +2709,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Divide A by B, and place the remainder in DST.
*/
- VM_DEFINE_OP (91, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2912,7 +2720,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the modulo of A by B in DST.
*/
- VM_DEFINE_OP (92, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2923,7 +2731,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Shift A arithmetically by B bits, and place the result in DST.
*/
- VM_DEFINE_OP (93, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2959,7 +2767,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the bitwise AND of A and B into DST.
*/
- VM_DEFINE_OP (94, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2973,7 +2781,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the bitwise inclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (95, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2987,7 +2795,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the bitwise exclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (96, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -3000,7 +2808,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store the length of the vector in SRC in DST.
*/
- VM_DEFINE_OP (97, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -3017,7 +2825,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Fetch the item at position IDX in the vector in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (98, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -3038,7 +2846,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Fill DST with the item IDX elements into the vector at SRC. Useful
* for building data types using vectors.
*/
- VM_DEFINE_OP (99, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (91, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -3057,7 +2865,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store SRC into the vector DST at index IDX.
*/
- VM_DEFINE_OP (100, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (92, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -3092,7 +2900,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (101, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (93, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
@@ -3105,7 +2913,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* will be constructed with space for NFIELDS fields, which should
* correspond to the field count of the VTABLE.
*/
- VM_DEFINE_OP (102, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (94, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, vtable, nfields;
SCM ret;
@@ -3124,7 +2932,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Fetch the item at slot IDX in the struct in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (103, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (obj, pos);
@@ -3158,7 +2966,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store SRC into the struct DST at slot IDX.
*/
- VM_DEFINE_OP (104, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (96, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, pos, val;
@@ -3199,7 +3007,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (105, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (97, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -3214,7 +3022,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
* index into the stack.
*/
- VM_DEFINE_OP (106, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (98, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
@@ -3228,7 +3036,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
* IDX is an 8-bit immediate value, not an index into the stack.
*/
- VM_DEFINE_OP (107, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (99, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
@@ -3249,7 +3057,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* from the instruction pointer, and store into DST. LEN is a byte
* length. OFFSET is signed.
*/
- VM_DEFINE_OP (108, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
+ VM_DEFINE_OP (100, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
{
scm_t_uint8 dst, type, shape;
scm_t_int32 offset;
@@ -3269,7 +3077,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
*/
- VM_DEFINE_OP (109, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (101, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, type, fill, bounds;
SCM_UNPACK_RTL_12_12 (op, dst, type);
@@ -3367,42 +3175,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
} while (0)
- VM_DEFINE_OP (110, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (102, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (111, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (103, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (112, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (104, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
- VM_DEFINE_OP (113, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (105, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
- VM_DEFINE_OP (114, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (106, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
#else
BV_INT_REF (u32, uint32, 4);
#endif
- VM_DEFINE_OP (115, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (107, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
#else
BV_INT_REF (s32, int32, 4);
#endif
- VM_DEFINE_OP (116, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (108, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (117, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (109, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (118, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (119, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f64, ieee_double, double, 8);
/* bv-u8-set! dst:8 idx:8 src:8
@@ -3506,42 +3314,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1); \
} while (0)
- VM_DEFINE_OP (120, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (112, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
- VM_DEFINE_OP (121, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (113, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
- VM_DEFINE_OP (122, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (114, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
- VM_DEFINE_OP (123, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (115, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2);
- VM_DEFINE_OP (124, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (116, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4);
#else
BV_INT_SET (u32, uint32, 4);
#endif
- VM_DEFINE_OP (125, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (117, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4);
#else
BV_INT_SET (s32, int32, 4);
#endif
- VM_DEFINE_OP (126, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (118, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (127, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (119, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (128, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (129, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f64, ieee_double, double, 8);
END_DISPATCH_SWITCH;
diff --git a/libguile/vm.c b/libguile/vm.c
index e87420b61..ad41180f1 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -599,22 +599,15 @@ static SCM rtl_apply;
static SCM rtl_values;
static const scm_t_uint32 rtl_boot_continuation_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_halt_values, 0),
SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
};
-static scm_t_uint32* rtl_boot_multiple_value_continuation_code =
- (scm_t_uint32 *) rtl_boot_continuation_code;
-
-static scm_t_uint32* rtl_boot_single_value_continuation_code =
- (scm_t_uint32 *) rtl_boot_continuation_code + 1;
-
static const scm_t_uint32 rtl_apply_code[] = {
SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r1, args from r2, nargs set */
};
static const scm_t_uint32 rtl_values_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_values, 0) /* vals from r1 */
+ SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
};
diff --git a/module/Makefile.am b/module/Makefile.am
index 495d228af..6d3b31f2d 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -32,6 +32,9 @@ nobase_ccache_DATA += ice-9/eval.go
EXTRA_DIST += ice-9/eval.scm
ETAGS_ARGS += ice-9/eval.scm
+VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go
+$(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
+
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm
# We can compile these in any order, but it's fastest if we compile
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 1eea3c05d..2c46c3b69 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -410,7 +410,11 @@ later by the linker."
(emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
((B1_U7_L24 a b label)
(record-label-reference asm label)
- (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))))
+ (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))
+ ((B1_X31 a)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_X7_U24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))))
(syntax-case x ()
((_ name opcode word0 word* ...)
@@ -675,12 +679,12 @@ returned instead."
(cond
(alternate
(emit-br-if-nargs-ne asm nreq alternate)
- (emit-reserve-locals asm nlocals))
+ (emit-alloc-frame asm nlocals))
((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
(emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
(else
(emit-assert-nargs-ee asm nreq)
- (emit-reserve-locals asm nlocals))))
+ (emit-alloc-frame asm nlocals))))
(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
(if alternate
@@ -693,7 +697,7 @@ returned instead."
(emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
(else
(emit-assert-nargs-le asm (+ nreq nopt))))
- (emit-reserve-locals asm nlocals))
+ (emit-alloc-frame asm nlocals))
(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
allow-other-keys? nlocals alternate)
@@ -711,41 +715,27 @@ returned instead."
(+ nreq nopt)
ntotal
kw-indices)
- (emit-reserve-locals asm nlocals)))
+ (emit-alloc-frame asm nlocals)))
(define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
-(define-macro-assembler (cache-current-module! asm tmp scope)
+(define-macro-assembler (cache-current-module! asm module scope)
(let ((mod-label (intern-module-cache-cell asm scope)))
- (emit-current-module asm tmp)
- (emit-static-set! asm tmp mod-label 0)))
-
-(define-macro-assembler (cached-toplevel-ref asm dst scope sym)
- (let ((sym-label (intern-non-immediate asm sym))
- (mod-label (intern-module-cache-cell asm scope))
- (cell-label (intern-cache-cell asm scope sym)))
- (emit-toplevel-ref asm dst cell-label mod-label sym-label)))
+ (emit-static-set! asm module mod-label 0)))
-(define-macro-assembler (cached-toplevel-set! asm src scope sym)
+(define-macro-assembler (cached-toplevel-box asm dst scope sym bound?)
(let ((sym-label (intern-non-immediate asm sym))
(mod-label (intern-module-cache-cell asm scope))
(cell-label (intern-cache-cell asm scope sym)))
- (emit-toplevel-set! asm src cell-label mod-label sym-label)))
+ (emit-toplevel-box asm dst cell-label mod-label sym-label bound?)))
-(define-macro-assembler (cached-module-ref asm dst module-name public? sym)
+(define-macro-assembler (cached-module-box asm dst module-name sym public? bound?)
(let* ((sym-label (intern-non-immediate asm sym))
(key (cons public? module-name))
(mod-name-label (intern-constant asm key))
(cell-label (intern-cache-cell asm key sym)))
- (emit-module-ref asm dst cell-label mod-name-label sym-label)))
-
-(define-macro-assembler (cached-module-set! asm src module-name public? sym)
- (let* ((sym-label (intern-non-immediate asm sym))
- (key (cons public? module-name))
- (mod-name-label (intern-non-immediate asm key))
- (cell-label (intern-cache-cell asm key sym)))
- (emit-module-set! asm src cell-label mod-name-label sym-label)))
+ (emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 3b95f196b..b339b5cbe 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -145,6 +145,11 @@
#'((not (zero? (logand word #x1)))
(logand (ash word -1) #x7f)
(unpack-s24 (ash word -8))))
+ ((B1_X31)
+ #'((not (zero? (logand word #x1)))))
+ ((B1_X7_U24)
+ #'((not (zero? (logand word #x1)))
+ (ash word -8)))
(else
(error "bad kind" type)))))
@@ -244,12 +249,14 @@ address of that offset."
addr)))
(('resolve-module dst name public)
(list "~a" (if (zero? public) "private" "public")))
- (((or 'toplevel-ref 'toplevel-set!) _ var-offset mod-offset sym-offset)
- (list "`~A'" (dereference-scm sym-offset)))
- (((or 'module-ref 'module-set!) _ var-offset mod-name-offset sym-offset)
+ (('toplevel-box _ var-offset mod-offset sym-offset bound?)
+ (list "`~A'~A" (dereference-scm sym-offset)
+ (if bound? "" " (maybe unbound)")))
+ (('module-box _ var-offset mod-name-offset sym-offset bound?)
(let ((mod-name (reference-scm mod-name-offset)))
- (list "`(~A ~A ~A)'" (if (car mod-name) '@ '@@) (cdr mod-name)
- (dereference-scm sym-offset))))
+ (list "`(~A ~A ~A)'~A" (if (car mod-name) '@ '@@) (cdr mod-name)
+ (dereference-scm sym-offset)
+ (if bound? "" " (maybe unbound)"))))
(('load-typed-array dst type shape target len)
(let ((addr (u32-offset->addr (+ offset target) context)))
(list "~a bytes from #x~X" len addr)))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index ce0a0c2c9..6f61f375f 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -92,7 +92,7 @@
(begin-standard-arity (x) 4 #f)
(br fix-body)
(label loop-head)
- (br-if-= 2 1 out)
+ (br-if-= 2 1 #f out)
(add 3 2 3)
(add1 2 2)
(br loop-head)
@@ -144,12 +144,11 @@
(assemble-program
'((begin-program call
((name . call)))
- (begin-standard-arity (f) 2 #f)
- (push-frame 2 1)
+ (begin-standard-arity (f) 7 #f)
(mov 5 1)
- (call 2)
- (return 2) ;; MVRA from call
- (return 2) ;; RA from call
+ (call 5 1)
+ (receive 2 5 7)
+ (return 2)
(end-arity)
(end-program)))))
(call (lambda () 42))))
@@ -159,13 +158,12 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (begin-standard-arity (f) 3 #f)
- (push-frame 2 2)
+ (begin-standard-arity (f) 7 #f)
(mov 5 1)
(load-constant 6 3)
- (call 2)
- (return 2) ;; MVRA from call
- (return 2) ;; RA from call
+ (call 5 2)
+ (receive 2 5 7)
+ (return 2)
(end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -177,7 +175,8 @@
'((begin-program call
((name . call)))
(begin-standard-arity (f) 2 #f)
- (tail-call 0 1)
+ (mov 0 1)
+ (tail-call 1)
(end-arity)
(end-program)))))
(call (lambda () 3))))
@@ -187,10 +186,10 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (begin-standard-arity (f) 3 #f)
- (mov 2 1) ;; R1 <- R0
- (load-constant 1 3) ;; R0 <- 3
- (tail-call 1 2)
+ (begin-standard-arity (f) 2 #f)
+ (mov 0 1) ;; R0 <- R1
+ (load-constant 1 3) ;; R1 <- 3
+ (tail-call 2)
(end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -202,6 +201,7 @@
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
(begin-standard-arity () 2 #f)
+ (current-module 1)
(cache-current-module! 1 sqrt-scope)
(load-static-procedure 1 sqrt-trampoline)
(return 1)
@@ -211,8 +211,9 @@
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
(begin-standard-arity (x) 3 #f)
- (cached-toplevel-ref 2 sqrt-scope sqrt)
- (tail-call 1 2)
+ (cached-toplevel-box 2 sqrt-scope sqrt #t)
+ (box-ref 0 2)
+ (tail-call 2)
(end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -227,6 +228,7 @@
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
(begin-standard-arity () 2 #f)
+ (current-module 1)
(cache-current-module! 1 top-incrementor)
(load-static-procedure 1 top-incrementor)
(return 1)
@@ -235,11 +237,12 @@
(begin-program top-incrementor
((name . top-incrementor)))
- (begin-standard-arity () 2 #f)
- (cached-toplevel-ref 1 top-incrementor *top-val*)
- (add1 1 1)
- (cached-toplevel-set! 1 top-incrementor *top-val*)
- (return/values 1)
+ (begin-standard-arity () 3 #f)
+ (cached-toplevel-box 1 top-incrementor *top-val* #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (return-values 0)
(end-arity)
(end-program)))))
((make-top-incrementor))
@@ -260,8 +263,9 @@
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
(begin-standard-arity (x) 3 #f)
- (cached-module-ref 2 (guile) #t sqrt)
- (tail-call 1 2)
+ (cached-module-box 2 (guile) sqrt #t #t)
+ (box-ref 0 2)
+ (tail-call 2)
(end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -281,11 +285,12 @@
(begin-program top-incrementor
((name . top-incrementor)))
- (begin-standard-arity () 2 #f)
- (cached-module-ref 1 (tests rtl) #f *top-val*)
- (add1 1 1)
- (cached-module-set! 1 (tests rtl) #f *top-val*)
- (return 1)
+ (begin-standard-arity () 3 #f)
+ (cached-module-box 1 (tests rtl) *top-val* #f #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (return 2)
(end-arity)
(end-program)))))
((make-top-incrementor))