[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-138-gaf95414
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-138-gaf95414 |
|
Date: |
Sun, 11 Aug 2013 14:54:46 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=af95414f1dcbacf7fd5311a3ee89a799b20fd17b
The branch, master has been updated
via af95414f1dcbacf7fd5311a3ee89a799b20fd17b (commit)
via 99983d544a931c29065ecb749acd349efc5f36c5 (commit)
via c1bff879980c3a2f107e8d7b54d0a6d8a18eefe4 (commit)
from 056e3470c4a0c18366c1da4f5052f36761824b70 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit af95414f1dcbacf7fd5311a3ee89a799b20fd17b
Author: Andy Wingo <address@hidden>
Date: Sun Aug 11 16:42:06 2013 +0200
Various RTL VM and calling convention tweaks
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Allow for
five-word instructions, and for new instruction word types.
* libguile/vm-engine.c (RETURN_ONE_VALUE): Instead of returning the
value in the fixed part of the call frame, return it in the same place
multiple-value returns go: from slot 1.
(BR_ARITHMETIC): Allow arithmetic tests to be negated.
(rtl_vm_engine): Change calling convention to use the same location
for single and multiple-value returns. Renumber all instructions.
(halt, halt/values): Fold into a single instruction (halt).
(call): Take the location of the procedure instead of the location of
the call frame. Also take the number of args, and reset the sp before
jumping to the procedure, so as to indicate the number of arguments.
(call/values): Remove, as the new calling convention has RA == MVRA.
(tail-call): Require the procedure to be shuffled down already, and
take "nlocals" as an arg instead of "nargs".
(receive, receive-values): New instructions, for receiving returned
values from calls.
(return-values): Rename from return/values. Remove "values".
(alloc-frame): Rename from reserve-locals.
(reset-frame): New instruction.
(drop-locals): Remove.
(br-if-=, br-if-<, br-if-<=): Allow these instructions to be
negatable.
(br-if->, br-if->=): Remove. Probably a bad idea, given NaN.
(box-ref): Don't bother trying to do a reverse lookup -- the
toplevel-box, module-box, and resolve instructions should handle
that.
(resolve): Add arg to check that the variable is bound.
(toplevel-box, module-box): New instructions, replacing toplevel-ref,
toplevel-set, module-ref, and module-set.
* libguile/vm.c (rtl_boot_continuation_code, rtl_values_code): Adapt to
instruction set changes.
* module/Makefile.am: Make the assembler and disassembler dependent on
vm-operations.h.
* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm: Adapt to instruction changes and
new instruction word kinds.
* test-suite/tests/rtl.test: Adapt to instruction set changes.
commit 99983d544a931c29065ecb749acd349efc5f36c5
Author: Andy Wingo <address@hidden>
Date: Mon Jul 29 21:55:39 2013 +0200
Inline escape-only prompt bodies in the Tree-IL
* module/language/scheme/decompile-tree-il.scm (do-decompile):
* module/language/tree-il/analyze.scm (analyze-lexicals):
* module/language/tree-il/canonicalize.scm (canonicalize):
* module/language/tree-il/compile-glil.scm (flatten-lambda-case):
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/peval.scm (peval):
* test-suite/tests/peval.test ("partial evaluation"): Partially revert
178a40928, so that escape-only prompts explicitly inline their bodies.
commit c1bff879980c3a2f107e8d7b54d0a6d8a18eefe4
Author: Andy Wingo <address@hidden>
Date: Mon Jul 29 21:30:49 2013 +0200
remove peval abort-in-tail-position optimization
* module/language/tree-il/peval.scm (peval): Remove abort optimization;
the CPS compiler will do much better here, and it is complicating
things in the meantime.
-----------------------------------------------------------------------
Summary of changes:
libguile/instructions.c | 12 +-
libguile/vm-engine.c | 746 ++++++++++----------------
libguile/vm.c | 9 +-
module/Makefile.am | 3 +
module/language/scheme/decompile-tree-il.scm | 6 +-
module/language/tree-il/analyze.scm | 22 +-
module/language/tree-il/canonicalize.scm | 66 +--
module/language/tree-il/compile-glil.scm | 7 +-
module/language/tree-il/cse.scm | 5 +-
module/language/tree-il/peval.scm | 48 +--
module/system/vm/assembler.scm | 40 +-
module/system/vm/disassembler.scm | 17 +-
test-suite/tests/peval.test | 8 +-
test-suite/tests/rtl.test | 65 ++-
14 files changed, 401 insertions(+), 653 deletions(-)
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 9e7e519..43937d7 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 613c638..369bb79 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 (¤t_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 (¤t_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 e87420b..ad41180 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 495d228..6d3b31f 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/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
index 74778b4..2decd97 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -432,10 +432,12 @@
`(call-with-values (lambda () ,@(recurse-body exp))
,(recurse (make-lambda #f '() body))))
- ((<prompt> tag body handler)
+ ((<prompt> escape-only? tag body handler)
`(call-with-prompt
,(recurse tag)
- ,(recurse body)
+ ,(if escape-only?
+ `(lambda () ,(recurse body))
+ (recurse body))
,(recurse handler)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 6b6df18..2f6e369 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -338,15 +338,8 @@
(lset-union eq? (step exp) (step body)))
((<prompt> escape-only? tag body handler)
- (match x
- ;; Escape-only: the body is inlined.
- (($ <prompt> _ #t tag
- ($ <lambda> _ _
- ($ <lambda-case> _ () #f #f #f () () body #f))
- ($ <lambda> _ _ handler))
- (lset-union eq? (step tag) (step body) (step-tail handler)))
- ;; Full: we make a closure.
- (($ <prompt> _ #f tag body ($ <lambda> _ _ handler))
+ (match handler
+ (($ <lambda> _ _ handler)
(lset-union eq? (step tag) (step body) (step-tail handler)))))
((<abort> tag args tail)
@@ -509,15 +502,8 @@
(max (recur exp) (recur body)))
((<prompt> escape-only? tag body handler)
- (match x
- ;; Escape-only: the body is inlined.
- (($ <prompt> _ #t tag
- ($ <lambda> _ _
- ($ <lambda-case> _ () #f #f #f () () body #f))
- ($ <lambda> _ _ handler))
- (max (recur tag) (recur body) (recur handler)))
- ;; Full: we make a closure.
- (($ <prompt> _ #f tag body ($ <lambda> _ _ handler))
+ (match handler
+ (($ <lambda> _ _ handler)
(max (recur tag) (recur body) (recur handler)))))
((<abort> tag args tail)
diff --git a/module/language/tree-il/canonicalize.scm
b/module/language/tree-il/canonicalize.scm
index 47c1db7..9de4caa 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -55,48 +55,28 @@
(make-const #f '())
(make-const #f #f)))
#f)))
- (($ <prompt> src)
- (define (ensure-lambda-body prompt)
- ;; If the prompt is escape-only, the body should be a thunk.
- (match prompt
- (($ <prompt> _ escape-only? tag body handler)
- (match body
- ((or ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
- (? (lambda _ (not escape-only?))))
- prompt)
- (else
- (make-prompt
- src escape-only? tag
- (make-lambda #f '()
- (make-lambda-case #f '() #f #f #f '() '()
- (make-call #f body '())
- #f))
- handler))))))
- (define (ensure-lambda-handler prompt)
- (match prompt
- (($ <prompt> _ escape-only? tag body handler)
- ;; The prompt handler should be a simple lambda, so that we
- ;; can inline it.
- (match handler
- (($ <lambda> _ _
- ($ <lambda-case> _ req #f rest #f () syms body #f))
- prompt)
- (else
- (let ((handler-sym (gensym))
- (args-sym (gensym)))
- (make-let
- #f (list 'handler) (list handler-sym) (list handler)
- (make-prompt
- src escape-only? tag body
- (make-lambda
- #f '()
- (make-lambda-case
- #f '() #f 'args #f '() (list args-sym)
- (make-primcall
- #f 'apply
- (list (make-lexical-ref #f 'handler handler-sym)
- (make-lexical-ref #f 'args args-sym)))
- #f))))))))))
- (ensure-lambda-handler (ensure-lambda-body x)))
+ (($ <prompt> src escape-only? tag body handler)
+ ;; The prompt handler should be a simple lambda, so that we
+ ;; can inline it.
+ (match handler
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req #f rest #f () syms body #f))
+ x)
+ (else
+ (let ((handler-sym (gensym))
+ (args-sym (gensym)))
+ (make-let
+ #f (list 'handler) (list handler-sym) (list handler)
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ #f '()
+ (make-lambda-case
+ #f '() #f 'args #f '() (list args-sym)
+ (make-primcall
+ #f 'apply
+ (list (make-lexical-ref #f 'handler handler-sym)
+ (make-lexical-ref #f 'args args-sym)))
+ #f))))))))
(_ x)))
x))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index fd67471..34855b9 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -958,12 +958,7 @@
((<prompt> src escape-only? tag body handler)
(let ((H (make-label))
(POST (make-label))
- (body (if escape-only?
- (match body
- (($ <lambda> _ _
- ($ <lambda-case> _ () #f #f #f () () body #f))
- body))
- (make-call #f body '()))))
+ (body (if escape-only? body (make-call #f body '()))))
;; First, set up the prompt.
(comp-push tag)
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 9e5157c..5d0277f 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -533,8 +533,9 @@
(concat db** db*)))))))
(($ <prompt> src escape-only? tag body handler)
(let*-values (((tag db*) (visit tag db env 'value))
- ((body _) (visit body (concat db* db) env ctx))
- ((handler _) (visit handler (concat db* db) env ctx)))
+ ((body _) (visit body (concat db* db) env
+ (if escape-only? ctx 'value)))
+ ((handler _) (visit handler (concat db* db) env 'value)))
(return (make-prompt src escape-only? tag body handler)
db*)))
(($ <abort> src tag args tail)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index af00e99..3d35039 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1522,7 +1522,7 @@ top-level bindings from ENV and return the resulting
expression."
(_ #f)))
(let ((tag (for-value tag))
- (body (for-value body)))
+ (body (if escape-only? (for-tail body) (for-value body))))
(cond
((find-definition tag 1)
(lambda (val op)
@@ -1532,42 +1532,7 @@ top-level bindings from ENV and return the resulting
expression."
;; for this <prompt>, so we can elide the <prompt>
;; entirely.
(unrecord-operand-uses op 1)
- (for-tail (make-call src body '()))))
- ((find-definition tag 2)
- (lambda (val op)
- (and (make-prompt-tag? val)
- (match body
- (($ <lambda> _ _
- ($ <lambda-case> _ () #f #f #f () ()
- ($ <abort> _ (? (cut tree-il=? <> tag)))))
- #t)
- (else #f))))
- => (lambda (val op)
- ;; (let ((t (make-prompt-tag)))
- ;; (call-with-prompt t
- ;; (lambda () (abort-to-prompt t val ...))
- ;; (lambda (k arg ...) e ...)))
- ;; => (call-with-values (lambda () (values values val ...))
- ;; (lambda (k arg ...) e ...))
- (unrecord-operand-uses op 2)
- (match body
- (($ <lambda> _ _
- ($ <lambda-case> _ () #f #f #f () ()
- ($ <abort> _ _ args tail)))
- (for-tail
- (make-primcall
- src 'call-with-values
- (list (make-lambda
- #f '()
- (make-lambda-case
- #f '() #f #f #f '() '()
- (make-primcall #f 'apply
- `(,(make-primitive-ref #f 'values)
- ,(make-primitive-ref #f 'values)
- ,@args
- ,tail))
- #f))
- handler)))))))
+ (for-tail (if escape-only? body (make-call src body '())))))
(else
(let ((handler (for-value handler)))
(define (escape-only-handler? handler)
@@ -1580,8 +1545,13 @@ top-level bindings from ENV and return the resulting
expression."
(_ #f))
body)))
(else #f)))
- (make-prompt src (or escape-only? (escape-only-handler? handler))
- tag body (for-value handler)))))))
+ (if (and (not escape-only?) (escape-only-handler? handler))
+ ;; Prompt transitioning to escape-only; transition body
+ ;; to be an expression.
+ (for-tail
+ (make-prompt src #t tag (make-call #f body '()) handler))
+ (make-prompt src escape-only? tag body handler)))))))
+
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 1eea3c0..2c46c3b 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 3b95f19..b339b5c 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/peval.test b/test-suite/tests/peval.test
index cb01b4b..0b981d8 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1137,10 +1137,7 @@
(lambda (k x) x))
(prompt #t
(toplevel tag)
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (const 1))))
+ (const 1)
(lambda _
(lambda-case
(((k x) #f #f #f () (_ _))
@@ -1272,6 +1269,9 @@
(apply (lambda (x y) (cons x y)) (list 1 2))
(primcall cons (const 1) (const 2)))
+ ;; Disable after removal of abort-in-tail-position optimization, in
+ ;; hopes that CPS does a uniformly better job.
+ #;
(pass-if-peval
(let ((t (make-prompt-tag)))
(call-with-prompt t
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index ce0a0c2..6f61f37 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))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-138-gaf95414,
Andy Wingo <=