summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-10-20 15:49:22 +0200
committerAndy Wingo <wingo@pobox.com>2013-10-20 15:59:14 +0200
commit56de3a697617332b6738611fa0b926a8e9d996d7 (patch)
tree628c102aa1b7ce1fe14f08633c6fe9345804e86a
parent749475bec492a61c4bbb41570eaf954e28e3fc37 (diff)
downloadguile-56de3a697617332b6738611fa0b926a8e9d996d7.tar.gz
VM has "builtins": primitives addressable by emitted RTL code
* libguile/Makefile.am: * libguile/vm-builtins.h: New header, declaring stubs needed by the compiler like values, apply, and abort-to-prompt. * libguile/vm.c: Adapt the apply and values stubs to conform to a standard interface. Add an abort-to-prompt stub. (scm_vm_builtin_ref): New helper, for the builtin-ref opcode. (scm_vm_builtin_name_to_index) (scm_vm_builtin_index_to_name): New helpers, for the compiler and disassembler, respectively. (scm_init_vm_builtins, scm_bootstrap_vm): Allow the compiler helpers to be loaded later into a module. * module/language/rtl.scm: Export builtin-index->name and builtin-name->index. * libguile/vm-engine.c (RETURN_VALUE_LIST): Update to use new names of "apply" and "values". (abort): Update to be a tail VM op, and reorder and renumber other ops. (builtin-ref): New opcode. * module/language/tree-il/compile-cps.scm (convert): Convert to 'abort-to-prompt calls, possibly with 'apply, effectively undoing the tree-il transformation. * module/language/cps/reify-primitives.scm (builtin-ref): New helper. (reify-primitives): Convert builtin primitives to builtin-ref. * module/language/cps/dfg.scm (constant-needs-allocation?): * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add support for compiling builtin-ref. * module/system/vm/disassembler.scm (code-annotation): Add annotation for builtin-ref.
-rw-r--r--libguile/Makefile.am1
-rw-r--r--libguile/vm-builtins.h44
-rw-r--r--libguile/vm-engine.c281
-rw-r--r--libguile/vm.c90
-rw-r--r--module/language/cps/compile-rtl.scm2
-rw-r--r--module/language/cps/dfg.scm2
-rw-r--r--module/language/cps/reify-primitives.scm20
-rw-r--r--module/language/rtl.scm7
-rw-r--r--module/language/tree-il/compile-cps.scm14
-rw-r--r--module/system/vm/disassembler.scm4
10 files changed, 315 insertions, 150 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ce437e41e..e3a9e00ce 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -639,6 +639,7 @@ modinclude_HEADERS = \
values.h \
variable.h \
vectors.h \
+ vm-builtins.h \
vm-expand.h \
vm.h \
vports.h \
diff --git a/libguile/vm-builtins.h b/libguile/vm-builtins.h
new file mode 100644
index 000000000..2a55a4234
--- /dev/null
+++ b/libguile/vm-builtins.h
@@ -0,0 +1,44 @@
+/* Copyright (C) 2013 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifndef _SCM_VM_BUILTINS_H_
+#define _SCM_VM_BUILTINS_H_
+
+#ifdef BUILDING_LIBGUILE
+
+#define FOR_EACH_VM_BUILTIN(M) \
+ M(apply, APPLY) \
+ M(values, VALUES) \
+ M(abort_to_prompt, ABORT_TO_PROMPT) \
+
+/* These enumerated values are embedded in RTL code, and as such are
+ part of Guile's ABI. */
+enum scm_vm_builtins
+{
+#define ENUM(builtin, BUILTIN) SCM_VM_BUILTIN_##BUILTIN,
+ FOR_EACH_VM_BUILTIN(ENUM)
+#undef ENUM
+ SCM_VM_BUILTIN_COUNT
+};
+
+SCM_INTERNAL SCM scm_vm_builtin_name_to_index (SCM name);
+SCM_INTERNAL SCM scm_vm_builtin_index_to_name (SCM idx);
+
+#endif /* BUILDING_LIBGUILE */
+
+#endif /* _SCM_VM_BUILTINS_H_ */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 573357848..a251e101e 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -659,11 +659,11 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
do { \
SCM vals = vals_; \
VM_HANDLE_INTERRUPTS; \
- fp[-1] = rtl_apply; \
- fp[0] = rtl_values; \
+ fp[-1] = vm_builtin_apply; \
+ fp[0] = vm_builtin_values; \
fp[1] = vals; \
RESET_FRAME (3); \
- ip = (scm_t_uint32 *) rtl_apply_code; \
+ ip = (scm_t_uint32 *) vm_builtin_apply_code; \
goto op_tail_apply; \
} while (0)
@@ -1382,6 +1382,39 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
}
}
+ /* abort _:24
+ *
+ * Abort to a prompt handler. The tag is expected in r1, and the rest
+ * of the values in the frame are returned to the prompt handler.
+ * This corresponds to a tail application of abort-to-prompt.
+ */
+ VM_DEFINE_OP (13, abort, "abort", OP1 (U8_X24))
+ {
+ scm_t_uint32 nlocals = FRAME_LOCALS_COUNT ();
+
+ ASSERT (nlocals >= 2);
+ SYNC_IP ();
+ vm_abort (vm, LOCAL_REF (1), nlocals - 2, &LOCAL_REF (2),
+ SCM_EOL, &LOCAL_REF (1), &registers);
+
+ /* vm_abort should not return */
+ abort ();
+ }
+
+ /* builtin-ref dst:12 idx:12
+ *
+ * Load a builtin stub by index into DST.
+ */
+ VM_DEFINE_OP (14, builtin_ref, "builtin-ref", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, idx;
+
+ SCM_UNPACK_RTL_12_12 (op, dst, idx);
+ LOCAL_SET (dst, scm_vm_builtin_ref (idx));
+
+ NEXT (1);
+ }
+
@@ -1397,15 +1430,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 (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (15, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
{
BR_NARGS (!=);
}
- VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (16, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (<);
}
- VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (17, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (>);
}
@@ -1417,7 +1450,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 (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
+ VM_DEFINE_OP (18, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1425,7 +1458,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 (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
+ VM_DEFINE_OP (19, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1433,7 +1466,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 (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
+ VM_DEFINE_OP (20, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1448,7 +1481,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* setting them all to SCM_UNDEFINED, except those nargs values that
* were passed as arguments and procedure.
*/
- VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24))
+ VM_DEFINE_OP (21, alloc_frame, "alloc-frame", OP1 (U8_U24))
{
scm_t_uint32 nlocals, nargs;
SCM_UNPACK_RTL_24 (op, nlocals);
@@ -1467,7 +1500,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* 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))
+ VM_DEFINE_OP (22, reset_frame, "reset-frame", OP1 (U8_U24))
{
scm_t_uint32 nlocals;
SCM_UNPACK_RTL_24 (op, nlocals);
@@ -1480,7 +1513,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
* number of locals reserved is EXPECTED + NLOCALS.
*/
- VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (23, 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);
@@ -1505,7 +1538,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* A macro-mega-instruction.
*/
- VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
+ VM_DEFINE_OP (24, 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;
@@ -1591,7 +1624,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 (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (25, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst, nargs;
SCM rest = SCM_EOL;
@@ -1633,7 +1666,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 (24, br, "br", OP1 (U8_L24))
+ VM_DEFINE_OP (26, br, "br", OP1 (U8_L24))
{
scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */
@@ -1645,7 +1678,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 (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (27, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_true (x));
}
@@ -1655,7 +1688,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 (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (28, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_null (x));
}
@@ -1665,7 +1698,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 (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (29, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_lisp_false (x));
}
@@ -1675,7 +1708,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 (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (30, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_pair (x));
}
@@ -1685,7 +1718,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 (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (31, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_STRUCTP (x));
}
@@ -1695,7 +1728,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 (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (32, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_CHARP (x));
}
@@ -1705,7 +1738,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 (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
+ VM_DEFINE_OP (33, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
{
BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
}
@@ -1715,7 +1748,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 (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (34, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y, scm_is_eq (x, y));
}
@@ -1725,7 +1758,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 (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (35, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1740,7 +1773,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* 24-bit number, to the current instruction pointer.
*/
// FIXME: should sync_ip before calling out?
- VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (36, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1753,7 +1786,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 (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (37, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (==, scm_num_eq_p);
}
@@ -1763,7 +1796,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 (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (38, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (<, scm_less_p);
}
@@ -1773,7 +1806,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 (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (39, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (<=, scm_leq_p);
}
@@ -1789,7 +1822,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 (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (40, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst;
scm_t_uint16 src;
@@ -1804,7 +1837,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 (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ VM_DEFINE_OP (41, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 src;
@@ -1820,7 +1853,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 (40, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (42, box, "box", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1833,7 +1866,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Unpack the variable at SRC into DST, asserting that the variable is
* actually bound.
*/
- VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (43, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1850,7 +1883,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 (42, box_set, "box-set!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (44, box_set, "box-set!", OP1 (U8_U12_U12))
{
scm_t_uint16 dst, src;
SCM var;
@@ -1868,7 +1901,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 (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
+ VM_DEFINE_OP (45, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
@@ -1892,7 +1925,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 (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
+ VM_DEFINE_OP (46, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
@@ -1907,7 +1940,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 (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
+ VM_DEFINE_OP (47, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
@@ -1930,7 +1963,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 (46, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
+ VM_DEFINE_OP (48, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1945,7 +1978,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 (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
+ VM_DEFINE_OP (49, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1960,7 +1993,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 (48, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
+ VM_DEFINE_OP (50, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1991,7 +2024,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 (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
+ VM_DEFINE_OP (51, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2020,7 +2053,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 (50, static_ref, "static-ref", OP2 (U8_U24, S32))
+ VM_DEFINE_OP (52, static_ref, "static-ref", OP2 (U8_U24, S32))
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2043,7 +2076,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 (51, static_set, "static-set!", OP2 (U8_U24, LO32))
+ VM_DEFINE_OP (53, static_set, "static-set!", OP2 (U8_U24, LO32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2065,7 +2098,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 (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
+ VM_DEFINE_OP (54, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2120,7 +2153,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store the current module in DST.
*/
- VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (55, current_module, "current-module", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
@@ -2137,7 +2170,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Resolve SYM in the current module, and place the resulting variable
* in DST.
*/
- VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
+ VM_DEFINE_OP (56, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 sym;
@@ -2161,7 +2194,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 (55, define, "define", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (57, define, "define", OP1 (U8_U12_U12))
{
scm_t_uint16 sym, val;
SCM_UNPACK_RTL_12_12 (op, sym, val);
@@ -2189,7 +2222,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* DST, and caching the resolved variable so that we will hit the cache next
* time.
*/
- VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
+ VM_DEFINE_OP (58, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2236,7 +2269,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Like toplevel-box, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
+ VM_DEFINE_OP (59, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2295,7 +2328,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* will expect a multiple-value return as if from a call with the
* procedure at PROC-SLOT.
*/
- VM_DEFINE_OP (58, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
+ VM_DEFINE_OP (60, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
{
scm_t_uint32 tag, proc_slot;
scm_t_int32 offset;
@@ -2327,7 +2360,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 (59, wind, "wind", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (61, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
@@ -2336,38 +2369,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1);
}
- /* 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 PROC.
- */
- VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24))
-#if 0
- {
- scm_t_uint32 tag, from, nvalues;
- SCM *base;
-
- SCM_UNPACK_RTL_24 (op, tag);
- SCM_UNPACK_RTL_24 (ip[1], from);
- base = (fp - 1) + from + 3;
- nvalues = FRAME_LOCALS_COUNT () - from - 3;
-
- SYNC_IP ();
- vm_abort (vm, LOCAL_REF (tag), base, nvalues, &registers);
-
- /* vm_abort should not return */
- abort ();
- }
-#else
- abort();
-#endif
-
/* unwind _:24
*
* A normal exit from the dynamic extent of an expression. Pop the top
* entry off of the dynamic stack.
*/
- VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24))
+ VM_DEFINE_OP (62, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (&current_thread->dynstack);
NEXT (1);
@@ -2379,7 +2386,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 (62, push_fluid, "push-fluid", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (63, push_fluid, "push-fluid", OP1 (U8_U12_U12))
{
scm_t_uint32 fluid, value;
@@ -2396,7 +2403,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 (63, pop_fluid, "pop-fluid", OP1 (U8_X24))
+ VM_DEFINE_OP (64, pop_fluid, "pop-fluid", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluid (&current_thread->dynstack,
@@ -2408,7 +2415,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 (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (65, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
@@ -2441,7 +2448,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 (65, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (66, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
@@ -2474,7 +2481,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 (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (67, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -2491,7 +2498,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 (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (68, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -2513,7 +2520,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 (68, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (69, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
@@ -2529,7 +2536,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 (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (70, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
@@ -2543,7 +2550,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 (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (71, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -2562,7 +2569,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 (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (72, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
@@ -2572,7 +2579,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (73, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
@@ -2583,7 +2590,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (74, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
@@ -2594,7 +2601,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (75, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2610,7 +2617,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (76, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2633,7 +2640,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 (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (77, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
@@ -2642,7 +2649,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 (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (78, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2667,7 +2674,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 (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (79, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
@@ -2676,7 +2683,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 (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (80, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2701,7 +2708,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 (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (81, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2712,7 +2719,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 (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (82, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2723,7 +2730,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 (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (83, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2734,7 +2741,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 (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (84, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2745,7 +2752,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 (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (85, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2756,7 +2763,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 (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (86, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2792,7 +2799,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 (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (87, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2806,7 +2813,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 (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (88, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2820,7 +2827,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 (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (89, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2833,7 +2840,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 (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (90, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -2850,7 +2857,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 (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (91, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -2871,7 +2878,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 (91, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (92, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -2890,7 +2897,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 (92, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (93, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -2925,7 +2932,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (93, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (94, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
@@ -2938,7 +2945,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 (94, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, vtable, nfields;
SCM ret;
@@ -2957,7 +2964,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 (95, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (96, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (obj, pos);
@@ -2991,7 +2998,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 (96, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (97, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, pos, val;
@@ -3032,7 +3039,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (97, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (98, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -3047,7 +3054,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 (98, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (99, 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);
@@ -3061,7 +3068,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 (99, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (100, 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);
@@ -3082,7 +3089,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 (100, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
+ VM_DEFINE_OP (101, 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;
@@ -3102,7 +3109,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 (101, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (102, 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);
@@ -3200,42 +3207,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 (102, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (103, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (103, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (104, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (104, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (105, 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 (105, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (106, 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 (106, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (107, 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 (107, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (108, 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 (108, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (109, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (109, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (110, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (111, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (112, 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
@@ -3339,42 +3346,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1); \
} while (0)
- VM_DEFINE_OP (112, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (113, 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 (113, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (114, 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 (114, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (115, 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 (115, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (116, 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 (116, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (117, 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 (117, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (118, 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 (118, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (119, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (119, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (120, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (121, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (122, 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 ff9ea35d3..e287d6f39 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -36,6 +36,7 @@
#include "objcodes.h"
#include "programs.h"
#include "vm.h"
+#include "vm-builtins.h"
#include "private-gc.h" /* scm_getenv_int */
@@ -602,21 +603,90 @@ vm_error_bad_wide_string_length (size_t len)
static SCM boot_continuation;
static SCM rtl_boot_continuation;
-static SCM rtl_apply;
-static SCM rtl_values;
+static SCM vm_builtin_apply;
+static SCM vm_builtin_values;
+static SCM vm_builtin_abort_to_prompt;
static const scm_t_uint32 rtl_boot_continuation_code[] = {
SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
};
-static const scm_t_uint32 rtl_apply_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0) /* proc in r1, args from r2, nargs set */
+static const scm_t_uint32 vm_builtin_apply_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 3),
+ SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0), /* proc in r1, args from r2 */
};
-static const scm_t_uint32 rtl_values_code[] = {
+static const scm_t_uint32 vm_builtin_values_code[] = {
SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
};
+static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_abort, 0), /* tag in r1, vals from r2 */
+ /* FIXME: Partial continuation should capture caller regs. */
+ SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+};
+
+
+static SCM
+scm_vm_builtin_ref (unsigned idx)
+{
+ switch (idx)
+ {
+#define INDEX_TO_NAME(builtin, BUILTIN) \
+ case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: abort();
+ }
+}
+
+SCM_SYMBOL(scm_sym_values, "values");
+SCM_SYMBOL(scm_sym_abort_to_prompt, "abort-to-prompt");
+
+SCM
+scm_vm_builtin_name_to_index (SCM name)
+#define FUNC_NAME "builtin-name->index"
+{
+ SCM_VALIDATE_SYMBOL (1, name);
+
+#define NAME_TO_INDEX(builtin, BUILTIN) \
+ if (scm_is_eq (name, scm_sym_##builtin)) \
+ return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
+ FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
+#undef NAME_TO_INDEX
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
+{
+ unsigned idx;
+
+ SCM_VALIDATE_UINT_COPY (1, index, idx);
+
+ switch (idx)
+ {
+#define INDEX_TO_NAME(builtin, BUILTIN) \
+ case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: return SCM_BOOL_F;
+ }
+}
+#undef FUNC_NAME
+
+static void
+scm_init_vm_builtins (void)
+{
+ scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
+ scm_vm_builtin_name_to_index);
+ scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
+ scm_vm_builtin_index_to_name);
+}
/*
@@ -1120,6 +1190,10 @@ scm_bootstrap_vm (void)
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_vm_builtins",
+ (scm_t_extension_init_func)scm_init_vm_builtins,
+ NULL);
initialize_default_stack_size ();
@@ -1135,8 +1209,10 @@ scm_bootstrap_vm (void)
SCM_SET_CELL_WORD_0 (rtl_boot_continuation,
(SCM_CELL_WORD_0 (rtl_boot_continuation)
| SCM_F_PROGRAM_IS_BOOT));
- rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
- rtl_values = scm_i_make_rtl_program (rtl_values_code);
+ vm_builtin_apply = scm_i_make_rtl_program (vm_builtin_apply_code);
+ vm_builtin_values = scm_i_make_rtl_program (vm_builtin_values_code);
+ vm_builtin_abort_to_prompt =
+ scm_i_make_rtl_program (vm_builtin_abort_to_prompt_code);
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 0303d6106..e1c3be4c0 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -184,6 +184,8 @@
(emit-resolve asm dst (constant bound?) (slot name)))
(($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx)))
+ (($ $primcall 'builtin-ref (name))
+ (emit-builtin-ref asm dst (constant name)))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-rtl-instruction name)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index ce36b1f24..bbf4785fd 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -628,6 +628,8 @@
#f)
(($ $primcall 'resolve (name bound?))
(eq? sym name))
+ (($ $primcall 'builtin-ref (idx))
+ #f)
(_ #t)))
uses))))))
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 34700b1ad..5c2725fed 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -50,6 +50,13 @@
(build-cps-term
($continue k ($primcall 'box-ref (box)))))))
+(define (builtin-ref idx k)
+ (let-gensyms (idx-sym)
+ (build-cps-term
+ ($letconst (('idx idx-sym idx))
+ ($continue k
+ ($primcall 'builtin-ref (idx-sym)))))))
+
(define (reify-clause ktail)
(let-gensyms (kclause kbody wna false str eol kthrow throw)
(build-cps-cont
@@ -97,7 +104,12 @@
,(match exp
(($ $prim name)
(match (lookup-cont k conts)
- (($ $kargs (_)) (primitive-ref name k))
+ (($ $kargs (_))
+ (cond
+ ((builtin-name->index name)
+ => (lambda (idx)
+ (builtin-ref idx k)))
+ (else (primitive-ref name k))))
(_ (build-cps-term ($continue k ($void))))))
(($ $fun)
(build-cps-term ($continue k ,(visit-fun exp))))
@@ -114,7 +126,11 @@
(build-cps-term
($letk ((k* #f ($kargs (v) (v)
($continue k ($call v args)))))
- ,(primitive-ref name k*)))))))
+ ,(cond
+ ((builtin-name->index name)
+ => (lambda (idx)
+ (builtin-ref idx k*)))
+ (else (primitive-ref name k*)))))))))
(_ term)))))
(visit-fun fun)))
diff --git a/module/language/rtl.scm b/module/language/rtl.scm
index d21751719..8ec9fe2f6 100644
--- a/module/language/rtl.scm
+++ b/module/language/rtl.scm
@@ -23,7 +23,12 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (system vm instruction)
#:re-export (rtl-instruction-list)
- #:export (rtl-instruction-arity))
+ #:export (rtl-instruction-arity
+ builtin-name->index
+ builtin-index->name))
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_vm_builtins")
(define (compute-rtl-instruction-arity name args)
(define (first-word-arity word)
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 707e08b10..45b7ad72b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -444,10 +444,20 @@
k
subst)))
+ (($ <abort> src tag args ($ <const> _ ()))
+ (convert-args (cons tag args)
+ (lambda (args*)
+ (build-cps-term
+ ($continue k ($primcall 'abort-to-prompt args*))))))
+
(($ <abort> src tag args tail)
- (convert-args (append (list tag) args (list tail))
+ (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
+ tag)
+ args
+ (list tail))
(lambda (args*)
- (build-cps-term ($continue k ($primcall 'abort args*))))))
+ (build-cps-term
+ ($continue k ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate)
(let-gensyms (kif kt kf)
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 09ca337bf..d2cad12cd 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -19,7 +19,7 @@
;;; Code:
(define-module (system vm disassembler)
- #:use-module (system vm instruction)
+ #:use-module (language rtl)
#:use-module (system vm elf)
#:use-module (system vm debug)
#:use-module (system vm program)
@@ -240,6 +240,8 @@ address of that offset."
nfree)))
(('make-non-immediate dst target)
(list "~@Y" (reference-scm target)))
+ (('builtin-ref dst idx)
+ (list "~A" (builtin-index->name idx)))
(((or 'static-ref 'static-set!) _ target)
(list "~@Y" (dereference-scm target)))
(('link-procedure! src target)