[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-940-gb83ab09
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-940-gb83ab09 |
|
Date: |
Tue, 14 May 2013 09:18:18 +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=b83ab09cff1a175ff28b5f9330f306a88b0c7b9b
The branch, wip-rtl has been updated
via b83ab09cff1a175ff28b5f9330f306a88b0c7b9b (commit)
via 40592f10a93212e6990b82a62895abf7a0ee1ca7 (commit)
via 7198e5236c9fbfc601146487a6787022816e0037 (commit)
via 33c31d62ffe5f0cc8acbdc8d178875fde086eefd (commit)
via 20f96f18e1c6a7c1d40de40bd2fb4cf7aa568a49 (commit)
via 7dc8d8aaaacf748db8140ad1b666f746e9ba34c0 (commit)
via f92d8f8802edd6a3d9c9f2efde75963c91a949da (commit)
from ed0495dc539d5ab3a18659692a3c351bc72fd7de (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 b83ab09cff1a175ff28b5f9330f306a88b0c7b9b
Author: Andy Wingo <address@hidden>
Date: Tue May 14 11:18:05 2013 +0200
Beginnings of tracking of procedure arities in assembler
* module/system/vm/assembler.scm (<meta>, <arity>): Assembler now tracks
arities of a function.
(begin-standard-arity, begin-opt-arity, begin-kw-arity, end-arity):
New macro-assemblers.
* test-suite/tests/rtl.test: Adapt all tests to use begin-standard-arity
and end-arity.
commit 40592f10a93212e6990b82a62895abf7a0ee1ca7
Author: Andy Wingo <address@hidden>
Date: Tue May 14 10:33:43 2013 +0200
add procedure prelude macro-instructions
* module/system/vm/assembler.scm (pack-flags): New helper.
(standard-prelude, opt-prelude, kw-prelude): New macro-instructions.
* test-suite/tests/rtl.test: Update tests to use standard-prelude.
commit 7198e5236c9fbfc601146487a6787022816e0037
Author: Andy Wingo <address@hidden>
Date: Tue May 14 10:25:38 2013 +0200
begin-program takes properties alist
* module/system/vm/assembler.scm (check): New helper macro to check
argument types.
(<meta>): Add properties field. Rename name field to "label" to
indicate that it should be unique.
(make-meta, meta-name): New helpers.
(begin-program): Take additional properties argument.
(emit-init-constants): Adapt to begin-program change.
(link-symtab): Allow for anonymous procedures.
* test-suite/tests/rtl.test: Adapt tests.
commit 33c31d62ffe5f0cc8acbdc8d178875fde086eefd
Author: Andy Wingo <address@hidden>
Date: Tue May 14 10:17:07 2013 +0200
"Flag" operands represented with booleans
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Change the
U1_ word types to be B1_ instead, indicating that the Scheme
representation of that operand component should be a boolean.
(br-if-true, br-if-null, br-if-nil, br-if-pair, br-if-struct)
(br-if-char, br-if-tc7, br-if-eq, br-if-eqv, br-if-equal): Update.
* module/system/vm/assembler.scm (assembler):
* module/system/vm/disassembler.scm (disassembler): Update.
commit 20f96f18e1c6a7c1d40de40bd2fb4cf7aa568a49
Author: Andy Wingo <address@hidden>
Date: Tue May 14 09:48:34 2013 +0200
assembler refactor
* module/system/vm/assembler.scm (assembler, cache-current-module!)
(emit-text): Reset the asm-start after writing opcodes instead of
beforehand.
(reset-asm-start!): Use asm-pos helper.
commit 7dc8d8aaaacf748db8140ad1b666f746e9ba34c0
Author: Andy Wingo <address@hidden>
Date: Tue May 14 09:32:02 2013 +0200
Add a DWARF comment.
* module/system/vm/dwarf.scm: Comment <dwarf-context>.
commit f92d8f8802edd6a3d9c9f2efde75963c91a949da
Author: Andy Wingo <address@hidden>
Date: Tue May 14 09:31:37 2013 +0200
add assert-nargs-le RTL VM op
* libguile/vm-engine.c (assert-nargs-le): New VM op.
-----------------------------------------------------------------------
Summary of changes:
libguile/instructions.c | 6 +-
libguile/vm-engine.c | 230 +++++++++++++++++++------------------
module/system/vm/assembler.scm | 148 +++++++++++++++++++++---
module/system/vm/disassembler.scm | 8 +-
module/system/vm/dwarf.scm | 4 +
test-suite/tests/rtl.test | 108 ++++++++++++------
6 files changed, 335 insertions(+), 169 deletions(-)
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 11004fc..08f7cd6 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 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
@@ -64,8 +64,8 @@ struct scm_instruction {
M(X8_U12_U12) \
M(X8_R24) \
M(X8_L24) \
- M(U1_X7_L24) \
- M(U1_U7_L24)
+ M(B1_X7_L24) \
+ M(B1_U7_L24)
#define TYPE_WIDTH 5
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2738b9c..3def7a3 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1427,8 +1427,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* assert-nargs-ee expected:24
* assert-nargs-ge expected:24
+ * assert-nargs-le expected:24
*
- * If the number of actual arguments is not == or >= to EXPECTED,
+ * If the number of actual arguments is not ==, >=, or <= EXPECTED,
* respectively, signal an error.
*/
VM_DEFINE_OP (17, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
@@ -1449,6 +1450,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
FRAME_LOCALS_COUNT ()));
NEXT (1);
}
+ VM_DEFINE_OP (19, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
+ {
+ scm_t_uint32 expected;
+ SCM_UNPACK_RTL_24 (op, expected);
+ VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
+ vm_error_wrong_num_args (vm, SCM_FRAME_PROGRAM (fp),
+ FRAME_LOCALS_COUNT ()));
+ NEXT (1);
+ }
/* reserve-locals nlocals:24
*
@@ -1456,7 +1466,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.
*/
- VM_DEFINE_OP (19, reserve_locals, "reserve-locals", OP1 (U8_U24))
+ VM_DEFINE_OP (20, reserve_locals, "reserve-locals", OP1 (U8_U24))
{
scm_t_uint32 nlocals, nargs;
SCM_UNPACK_RTL_24 (op, nlocals);
@@ -1474,7 +1484,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 (20, 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);
@@ -1501,7 +1511,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* A macro-mega-instruction.
*/
- VM_DEFINE_OP (21, 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;
@@ -1585,7 +1595,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 (22, 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;
@@ -1611,7 +1621,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Reset the stack pointer to only have space for NLOCALS values.
* Used after extracting values from an MV return.
*/
- VM_DEFINE_OP (23, drop_values, "drop-values", OP1 (U8_U24))
+ VM_DEFINE_OP (24, drop_values, "drop-values", OP1 (U8_U24))
{
scm_t_bits nlocals;
@@ -1634,7 +1644,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 (25, br, "br", OP1 (U8_L24))
{
scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */
@@ -1646,7 +1656,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, U1_X7_L24))
+ VM_DEFINE_OP (26, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_true (x));
}
@@ -1656,7 +1666,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, U1_X7_L24))
+ VM_DEFINE_OP (27, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_null (x));
}
@@ -1666,7 +1676,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, U1_X7_L24))
+ VM_DEFINE_OP (28, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_lisp_false (x));
}
@@ -1676,7 +1686,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, U1_X7_L24))
+ VM_DEFINE_OP (29, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_pair (x));
}
@@ -1686,7 +1696,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, U1_X7_L24))
+ VM_DEFINE_OP (30, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_STRUCTP (x));
}
@@ -1696,7 +1706,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, U1_X7_L24))
+ VM_DEFINE_OP (31, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_CHARP (x));
}
@@ -1706,7 +1716,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, U1_U7_L24))
+ VM_DEFINE_OP (32, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
{
BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
}
@@ -1716,7 +1726,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, U1_X7_L24))
+ VM_DEFINE_OP (33, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y, scm_is_eq (x, y));
}
@@ -1726,7 +1736,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, U1_X7_L24))
+ VM_DEFINE_OP (34, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1740,7 +1750,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, U1_X7_L24))
+ VM_DEFINE_OP (35, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1753,7 +1763,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, X8_L24))
+ VM_DEFINE_OP (36, br_if_ee, "br-if-=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (==, scm_num_eq_p);
}
@@ -1763,7 +1773,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, X8_L24))
+ VM_DEFINE_OP (37, br_if_lt, "br-if-<", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (<, scm_less_p);
}
@@ -1773,7 +1783,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, X8_L24))
+ VM_DEFINE_OP (38, br_if_le, "br-if-<=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (<=, scm_leq_p);
}
@@ -1783,7 +1793,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_gt, "br-if->", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (39, br_if_gt, "br-if->", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (>, scm_gr_p);
}
@@ -1793,7 +1803,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 (39, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (40, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (>=, scm_geq_p);
}
@@ -1809,7 +1819,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 (40, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (41, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst;
scm_t_uint16 src;
@@ -1824,7 +1834,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 (41, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ VM_DEFINE_OP (42, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 src;
@@ -1840,7 +1850,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 (42, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (43, box, "box", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1854,7 +1864,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* general implementation of `letrec', in those cases that fix-letrec
* fails to fix.
*/
- VM_DEFINE_OP (43, empty_box, "empty-box", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (44, empty_box, "empty-box", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
SCM_UNPACK_RTL_24 (op, dst);
@@ -1867,7 +1877,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 (44, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (45, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1890,7 +1900,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 (45, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (46, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1905,7 +1915,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Load free variable SRC into local slot DST.
*/
- VM_DEFINE_OP (46, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (47, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1921,7 +1931,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* signed 32-bit integer. The registers for the NFREE free variables
* follow.
*/
- VM_DEFINE_OP (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_R24) |
OP_DST)
+ VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_R24) |
OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
@@ -1948,7 +1958,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* free variables to point to each other. NFREE and the locals FREE0...
* are as in make-closure.
*/
- VM_DEFINE_OP (48, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (49, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24))
{
scm_t_uint32 dst, nfree, n;
SCM closure;
@@ -1973,7 +1983,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 (49, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
+ VM_DEFINE_OP (50, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1988,7 +1998,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 (50, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
+ VM_DEFINE_OP (51, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2003,7 +2013,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 (51, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
+ VM_DEFINE_OP (52, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2034,7 +2044,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 (52, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
+ VM_DEFINE_OP (53, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2063,7 +2073,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 (53, static_ref, "static-ref", OP2 (U8_U24, S32))
+ VM_DEFINE_OP (54, static_ref, "static-ref", OP2 (U8_U24, S32))
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2086,7 +2096,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 (54, static_set, "static-set!", OP2 (U8_U24, LO32))
+ VM_DEFINE_OP (55, static_set, "static-set!", OP2 (U8_U24, LO32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2108,7 +2118,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 (55, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
+ VM_DEFINE_OP (56, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2169,7 +2179,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the current module in DST.
*/
- VM_DEFINE_OP (56, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (57, current_module, "current-module", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
@@ -2185,7 +2195,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Resolve SYM in MOD, and place the resulting variable in DST.
*/
- VM_DEFINE_OP (57, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (58, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, mod, sym;
@@ -2203,7 +2213,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* nonzero, resolve the public interface, otherwise use the private
* interface.
*/
- VM_DEFINE_OP (58, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
+ VM_DEFINE_OP (59, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
{
scm_t_uint8 dst, name, public;
SCM mod;
@@ -2224,7 +2234,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 (59, define, "define", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (60, define, "define", OP1 (U8_U12_U12))
{
scm_t_uint16 sym, val;
SCM_UNPACK_RTL_12_12 (op, sym, val);
@@ -2252,7 +2262,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* an error if it is unbound, unbox it into DST, and cache the
* resolved variable so that we will hit the cache next time.
*/
- VM_DEFINE_OP (60, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
+ VM_DEFINE_OP (61, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2298,7 +2308,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Set a top-level variable from a variable cache cell. The variable
* is resolved as in toplevel-ref.
*/
- VM_DEFINE_OP (61, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
+ VM_DEFINE_OP (62, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
{
scm_t_uint32 src;
scm_t_int32 var_offset;
@@ -2343,7 +2353,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Like toplevel-ref, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (62, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
+ VM_DEFINE_OP (63, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2393,7 +2403,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Like toplevel-set!, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (63, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
+ VM_DEFINE_OP (64, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
{
scm_t_uint32 src;
scm_t_int32 var_offset;
@@ -2448,7 +2458,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 (64, prompt, "prompt", OP2 (U8_U24, U8_L24))
+ VM_DEFINE_OP (65, prompt, "prompt", OP2 (U8_U24, U8_L24))
#if 0
{
scm_t_uint32 tag;
@@ -2480,7 +2490,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 (65, wind, "wind", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (66, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
@@ -2495,7 +2505,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* VAL1, etc are 24-bit values, in the lower 24 bits of their words.
* The upper 8 bits are 0.
*/
- VM_DEFINE_OP (66, abort, "abort", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (67, abort, "abort", OP2 (U8_U24, X8_R24))
#if 0
{
scm_t_uint32 tag, nvalues;
@@ -2518,7 +2528,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 (67, unwind, "unwind", OP1 (U8_X24))
+ VM_DEFINE_OP (68, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (¤t_thread->dynstack);
NEXT (1);
@@ -2530,7 +2540,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 (68, wind_fluids, "wind-fluids", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (69, wind_fluids, "wind-fluids", OP2 (U8_U24, X8_R24))
#if 0
{
scm_t_uint32 fluid_base, n;
@@ -2552,7 +2562,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 (69, unwind_fluids, "unwind-fluids", OP1 (U8_X24))
+ VM_DEFINE_OP (70, unwind_fluids, "unwind-fluids", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluids (¤t_thread->dynstack,
@@ -2564,7 +2574,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 (70, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (71, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
@@ -2597,7 +2607,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 (71, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (72, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
@@ -2630,7 +2640,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 (72, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (73, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -2647,7 +2657,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 (73, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (74, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -2669,7 +2679,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 (74, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (75, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2685,7 +2695,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 (75, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (76, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2699,7 +2709,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 (76, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (77, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -2718,7 +2728,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 (77, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (78, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
@@ -2728,7 +2738,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (78, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (79, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
@@ -2739,7 +2749,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (79, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (80, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
@@ -2750,7 +2760,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (80, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (81, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2766,7 +2776,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (81, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (82, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2789,7 +2799,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 (82, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (83, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
@@ -2798,7 +2808,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 (83, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (84, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2824,7 +2834,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 (84, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (85, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
@@ -2833,7 +2843,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 (85, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (86, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2859,7 +2869,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 (86, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (87, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2870,7 +2880,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 (87, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (88, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2881,7 +2891,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 (88, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (89, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2892,7 +2902,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 (89, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (90, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2903,7 +2913,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 (90, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (91, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2914,7 +2924,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 (91, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (92, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2947,7 +2957,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 (92, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (93, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2960,7 +2970,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 (93, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (94, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2973,7 +2983,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 (94, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2986,7 +2996,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 (95, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (96, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -3003,7 +3013,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 (96, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (97, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -3024,7 +3034,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 (97, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (98, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -3043,7 +3053,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 (98, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (99, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -3078,7 +3088,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (99, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (100, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
@@ -3092,7 +3102,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the locals given by INIT0.... The format of INIT0... is as in the
* "call" opcode: unsigned 24-bit values, with 0 in the high byte.
*/
- VM_DEFINE_OP (100, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
+ VM_DEFINE_OP (101, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
#if 0
{
scm_t_uint16 dst, vtable_r;
@@ -3135,7 +3145,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 (101, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (102, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (obj, pos);
@@ -3169,7 +3179,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 (102, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (103, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, pos, val;
@@ -3210,7 +3220,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (103, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (104, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -3225,7 +3235,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 (104, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (105, 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);
@@ -3239,7 +3249,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 (105, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (106, 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);
@@ -3260,7 +3270,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 (106, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
+ VM_DEFINE_OP (107, 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;
@@ -3280,7 +3290,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 (107, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (108, 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);
@@ -3378,42 +3388,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 (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (109, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (110, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, 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 (111, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (112, 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 (112, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (113, 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 (113, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (114, 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 (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (115, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (116, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (117, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (117, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (118, 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
@@ -3517,42 +3527,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1); \
} while (0)
- VM_DEFINE_OP (118, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (119, 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 (119, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, 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 (120, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, 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 (121, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (122, 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 (122, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (123, 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 (123, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (124, 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 (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (125, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (126, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (127, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (128, 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/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7c7fb48..36d6a63 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -26,6 +26,7 @@
#:use-module (system vm objcode)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-9)
@@ -35,6 +36,12 @@
link-assembly
assemble-program))
+(define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 2 0) 0)))))
+
(define-syntax-rule (pack-u8-u24 x y)
(logior x (ash y 8)))
@@ -59,12 +66,42 @@
(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
(logior x (ash y 8) (ash z 16) (ash w 24)))
+(define-syntax-rule (check arg pattern kind)
+ (let ((x arg))
+ (unless (match x (pattern #t) (_ #f))
+ (error (string-append "expected " kind) x))))
+
(define-record-type <meta>
- (make-meta name low-pc high-pc)
+ (%make-meta label properties low-pc high-pc arities)
meta?
- (name meta-name)
+ (label meta-label)
+ (properties meta-properties set-meta-properties!)
(low-pc meta-low-pc)
- (high-pc meta-high-pc set-meta-high-pc!))
+ (high-pc meta-high-pc set-meta-high-pc!)
+ (arities meta-arities set-meta-arities!))
+
+(define (make-meta label properties low-pc)
+ (check label (? symbol?) "symbol")
+ (check properties (((? symbol?) . _) ...) "alist with symbolic keys")
+ (%make-meta label properties low-pc #f '()))
+
+(define (meta-name meta)
+ (assq-ref (meta-properties meta) 'name))
+
+;; Metadata for one <lambda-case>.
+(define-record-type <arity>
+ (make-arity req opt rest kw-indices allow-other-keys?
+ nlocals alternate low-pc high-pc)
+ arity?
+ (req arity-req)
+ (opt arity-opt)
+ (rest arity-rest)
+ (kw-indices arity-kw-indices)
+ (allow-other-keys? arity-allow-other-keys?)
+ (nlocals arity-nlocals)
+ (alternate arity-alternate)
+ (low-pc arity-low-pc)
+ (high-pc arity-high-pc set-arity-high-pc!))
(define-syntax *block-size* (identifier-syntax 32))
@@ -151,7 +188,7 @@
(list type label base word))
(define-inlinable (reset-asm-start! asm)
- (set-asm-start! asm (+ (asm-idx asm) (asm-written asm))))
+ (set-asm-start! asm (asm-pos asm)))
(define (emit-exported-label asm label)
(set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
@@ -260,12 +297,12 @@
((X8_L24 label)
(record-label-reference asm label)
(emit asm 0))
- ((U1_X7_L24 a label)
+ ((B1_X7_L24 a label)
(record-label-reference asm label)
- (emit asm (pack-u1-u7-u24 a 0 0)))
- ((U1_U7_L24 a b label)
+ (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 a b 0)))))
+ (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))))
(syntax-case x ()
((_ name opcode word0 word* ...)
@@ -282,7 +319,7 @@
(unless (asm? asm) (error "not an asm"))
code0 ...
code* ... ...
- ))))))
+ (reset-asm-start! asm)))))))
(define assemblers (make-hash-table))
@@ -435,13 +472,93 @@
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
-(define-macro-assembler (begin-program asm label)
+(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
- (let ((meta (make-meta label (asm-start asm) #f)))
+ (let ((meta (make-meta label properties (asm-start asm))))
(set-asm-meta! asm (cons meta (asm-meta asm)))))
(define-macro-assembler (end-program asm)
- (set-meta-high-pc! (car (asm-meta asm)) (asm-start asm)))
+ (let ((meta (car (asm-meta asm))))
+ (set-meta-high-pc! meta (asm-start asm))
+ (set-meta-arities! meta (reverse (meta-arities meta)))))
+
+(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
+ (emit-begin-opt-arity asm req '() #f nlocals alternate))
+
+(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
+ (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+
+(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (check req ((? symbol?) ...) "list of symbols")
+ (check opt ((? symbol?) ...) "list of symbols")
+ (check rest (or #f (? symbol?)) "#f or symbol")
+ (check kw-indices (((? symbol?) . (? integer?)) ...)
+ "alist of symbol -> integer")
+ (check allow-other-keys? (? boolean?) "boolean")
+ (check nlocals (? integer?) "integer")
+ (check alternate (or #f (? symbol?)) "#f or symbol")
+ (let* ((meta (car (asm-meta asm)))
+ (arity (make-arity req opt rest kw-indices allow-other-keys?
+ nlocals alternate (asm-start asm) #f))
+ (nreq (length req))
+ (nopt (length opt))
+ (rest? (->bool rest)))
+ (set-meta-arities! meta (cons arity (meta-arities meta)))
+ (cond
+ ((or allow-other-keys? (pair? kw-indices))
+ (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys?
+ nlocals alternate))
+ ((or rest? (pair? opt))
+ (emit-opt-prelude asm nreq nopt rest? nlocals alternate))
+ (else
+ (emit-standard-prelude asm nreq nlocals alternate)))))
+
+(define-macro-assembler (end-arity asm)
+ (let ((arity (car (meta-arities (car (asm-meta asm))))))
+ (set-arity-high-pc! arity (asm-start asm))))
+
+(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
+ (cond
+ (alternate
+ (emit-br-if-nargs-ne asm nreq alternate)
+ (emit-reserve-locals 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))))
+
+(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (cond
+ (rest?
+ (emit-bind-rest asm (+ nreq nopt)))
+ (alternate
+ (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
+ (else
+ (emit-assert-nargs-le asm (+ nreq nopt))))
+ (emit-reserve-locals asm nlocals))
+
+(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
+ allow-other-keys? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (let ((ntotal (fold (lambda (kw ntotal)
+ (match kw
+ (((? keyword?) . idx)
+ (max (1+ idx) ntotal))))
+ (+ nreq nopt) kw-indices)))
+ ;; FIXME: port 581f410f
+ (emit-bind-kwargs asm nreq
+ (pack-flags allow-other-keys? rest?)
+ (+ nreq nopt)
+ ntotal
+ kw-indices)
+ (emit-reserve-locals asm nlocals)))
(define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
@@ -449,7 +566,6 @@
(define-macro-assembler (cache-current-module! asm tmp scope)
(let ((mod-label (emit-module-cache-cell asm scope)))
(emit-current-module asm tmp)
- (reset-asm-start! asm)
(emit-static-set! asm tmp mod-label 0)))
(define-macro-assembler (cached-toplevel-ref asm dst scope sym)
@@ -480,7 +596,6 @@
(define (emit-text asm instructions)
(for-each (lambda (inst)
- (reset-asm-start! asm)
(apply (or (hashq-ref assemblers (car inst))
(error 'bad-instruction inst))
asm
@@ -625,7 +740,7 @@
(and (not (null? inits))
(let ((label (gensym "init-constants")))
(emit-text asm
- `((begin-program ,label)
+ `((begin-program ,label ())
(assert-nargs-ee/locals 0 1)
,@(reverse inits)
(load-constant 0 ,*unspecified*)
@@ -823,7 +938,8 @@
(bv (make-bytevector (* n size) 0)))
(define (intern-string! name)
(call-with-values
- (lambda () (string-table-intern strtab (symbol->string name)))
+ (lambda () (string-table-intern strtab
+ (if name (symbol->string name) "")))
(lambda (table idx)
(set! strtab table)
idx)))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 7e949e0..123026c 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -141,11 +141,11 @@
#'(#:rest (ash word -8)))
((X8_L24)
#'((unpack-s24 (ash word -8))))
- ((U1_X7_L24)
- #'((logand word #x1)
+ ((B1_X7_L24)
+ #'((not (zero? (logand word #x1)))
(unpack-s24 (ash word -8))))
- ((U1_U7_L24)
- #'((logand word #x1)
+ ((B1_U7_L24)
+ #'((not (zero? (logand word #x1)))
(logand (ash word -1) #x7f)
(unpack-s24 (ash word -8))))
(else
diff --git a/module/system/vm/dwarf.scm b/module/system/vm/dwarf.scm
index b7dbed4..0d09287 100644
--- a/module/system/vm/dwarf.scm
+++ b/module/system/vm/dwarf.scm
@@ -692,6 +692,10 @@
(aranges-start meta-aranges-start)
(aranges-end meta-aranges-end))
+;; A context represents a namespace. The root context is the
+;; compilation unit. DIE nodes of type class-type, structure-type, or
+;; namespace may form child contexts.
+;;
(define-record-type <dwarf-context>
(make-dwarf-context bv word-size endianness meta
abbrevs
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 74a7ff3..5e7191b 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -25,10 +25,12 @@
(pass-if (object->string x) (equal? expr x))))
(define (return-constant val)
- (assemble-program `((begin-program foo)
- (assert-nargs-ee/locals 0 1)
+ (assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 1 #f)
(load-constant 0 ,val)
(return 0)
+ (end-arity)
(end-program))))
(define-syntax-rule (assert-constants val ...)
@@ -61,15 +63,19 @@
(with-test-prefix "static procedure"
(assert-equal 42
- (((assemble-program `((begin-program foo)
- (assert-nargs-ee/locals 0 1)
+ (((assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 bar)
(return 0)
+ (end-arity)
(end-program)
- (begin-program bar)
- (assert-nargs-ee/locals 0 1)
+ (begin-program bar
+ ((name . bar)))
+ (begin-standard-arity () 1 #f)
(load-constant 0 42)
(return 0)
+ (end-arity)
(end-program)))))))
(with-test-prefix "loop"
@@ -79,8 +85,9 @@
;; 0: limit
;; 1: n
;; 2: accum
- '((begin-program countdown)
- (assert-nargs-ee/locals 1 2)
+ '((begin-program countdown
+ ((name . countdown)))
+ (begin-standard-arity (x) 3 #f)
(br fix-body)
(label loop-head)
(br-if-= 1 0 out)
@@ -93,6 +100,7 @@
(br loop-head)
(label out)
(return 2)
+ (end-arity)
(end-program)))))
(sumto 1000))))
@@ -103,20 +111,24 @@
;; 0: elt
;; 1: tail
;; 2: head
- '((begin-program make-accum)
- (assert-nargs-ee/locals 0 2)
+ '((begin-program make-accum
+ ((name . make-accum)))
+ (begin-standard-arity () 2 #f)
(load-constant 0 0)
(box 0 0)
(make-closure 1 accum (0))
(return 1)
+ (end-arity)
(end-program)
- (begin-program accum)
- (assert-nargs-ee/locals 1 2)
+ (begin-program accum
+ ((name . accum)))
+ (begin-standard-arity (x) 3 #f)
(free-ref 1 0)
(box-ref 2 1)
(add 2 2 0)
(box-set! 1 2)
(return 2)
+ (end-arity)
(end-program)))))
(let ((accum (make-accum)))
(accum 1)
@@ -127,23 +139,27 @@
(assert-equal 42
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
- (assert-nargs-ee/locals 1 0)
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 1 #f)
(call 1 0 ())
(return 1) ;; MVRA from call
(return 1) ;; RA from call
+ (end-arity)
(end-program)))))
(call (lambda () 42))))
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
- (assert-nargs-ee/locals 1 1)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
(load-constant 1 3)
(call 2 0 (1))
(return 2) ;; MVRA from call
(return 2) ;; RA from call
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -151,20 +167,24 @@
(assert-equal 3
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
- (assert-nargs-ee/locals 1 0)
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 1 #f)
(tail-call 0 0)
+ (end-arity)
(end-program)))))
(call (lambda () 3))))
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
- (assert-nargs-ee/locals 1 1)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
(tail-call 1 1)
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -172,17 +192,21 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
- (begin-program sqrt-trampoline)
- (assert-nargs-ee/locals 1 1)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 2 #f)
(cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -193,19 +217,23 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
- (begin-program top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0)
(cached-toplevel-set! 0 top-incrementor *top-val*)
(return/values 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
@@ -214,16 +242,20 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
- (begin-program sqrt-trampoline)
- (assert-nargs-ee/locals 1 1)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 2 #f)
(cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -232,18 +264,22 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
- (begin-program top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0)
(cached-module-set! 0 (tests rtl) #f *top-val*)
(return 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-940-gb83ab09,
Andy Wingo <=