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=b0ed216b6f17f9f63fbf1d9542c0722241317837 The branch, wip-rtl-halloween has been updated via b0ed216b6f17f9f63fbf1d9542c0722241317837 (commit) via f90c0554640c6e0c28ec01ed597a3b78b47bdd29 (commit) via d2bd8fa810c130261135dd4b6676397ec517421f (commit) via be564260bef9b2d0f9df64affdbcf7e9b02507d2 (commit) via 6a59420a9d5ed5a3ee054f9de5615c577d1ec651 (commit) via 0e3a59f75050041f4f6b423a53193609335f708d (commit) via 1ab116f39075f8dcf1b6c8084d9afc547f9a85b7 (commit) via 3a858c327539522d39c6a46d3a573909b030680d (commit) via 697c4f29d93bb3b9dc44a666cf2e1b585f070da9 (commit) via 7a5a533595ec3df028adea46eebeb76f72c832ec (commit) from 581a4eb82b1534970060e3cbd79b9a96d351edf9 (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 b0ed216b6f17f9f63fbf1d9542c0722241317837 Author: Andy Wingo <[email protected]> Date: Fri Nov 8 11:41:28 2013 +0100 Fix case-lambda* dispatching to agree with manual. * module/system/vm/assembler.scm (kw-prelude): Emit br-if-npos-gt as appropriate. commit f90c0554640c6e0c28ec01ed597a3b78b47bdd29 Author: Andy Wingo <[email protected]> Date: Fri Nov 8 11:38:34 2013 +0100 Add br-if-npos-gt * libguile/vm-engine.c (br-if-npos-gt): New instruction (sigh!). For case-lambda* dispatching on the number of positional args, as the manual describes. Renumber other opcodes. commit d2bd8fa810c130261135dd4b6676397ec517421f Author: Andy Wingo <[email protected]> Date: Fri Nov 8 11:36:53 2013 +0100 Fix BR_NARGS data type width * libguile/vm-engine.c (BR_NARGS): Fix width of "expected". Fixes bug with > 65536 arguments in case-lambda clauses. commit be564260bef9b2d0f9df64affdbcf7e9b02507d2 Author: Andy Wingo <[email protected]> Date: Fri Nov 8 10:59:52 2013 +0100 Fix arity selection in compute-contification * module/language/cps/contification.scm (compute-contification): Fail as soon as we see an arity with rest, optional, or keyword arguments. Fixes ((case-lambda ((a . b) #t) ((a b) #f)) 1 2). commit 6a59420a9d5ed5a3ee054f9de5615c577d1ec651 Author: Andy Wingo <[email protected]> Date: Fri Nov 8 10:37:09 2013 +0100 Fix error message in lambda* eval closures with keywords * module/ice-9/eval.scm (primitive-eval): For ((lambda* (#:key foo) foo) 'bar), give an "invalid keyword" error instead of a "wrong number of arguments" error. commit 0e3a59f75050041f4f6b423a53193609335f708d Author: Andy Wingo <[email protected]> Date: Fri Nov 8 10:03:48 2013 +0100 Fix reading and writing arities into DWARF. * libguile/gsubr.h: * libguile/gsubr.c (scm_i_primitive_call_ip): * libguile/programs.c (scm_primitive_call_ip): Adapt to return an absolute address. * module/system/vm/assembler.scm (write-arity-headers): Adapt to write byte addresses (relative to the text base). * module/system/vm/debug.scm (arity-low-pc, arity-high-pc): Return absolute addresses, instead of word offsets relative to the text base. (find-first-arity): Adapt for absolute addresses. * module/system/vm/program.scm (program-arguments-alist): Adapt for arity-low-pc / arity-high-pc absolute addresses. commit 1ab116f39075f8dcf1b6c8084d9afc547f9a85b7 Author: Andy Wingo <[email protected]> Date: Fri Nov 8 09:07:32 2013 +0100 Fix eval.test: stack involving a primitive * test-suite/tests/eval.test ("stacks"): Revert expect-fail introduced in 27337b6373954e1a975d97d0bf06b5c03d65b64d. commit 3a858c327539522d39c6a46d3a573909b030680d Author: Andy Wingo <[email protected]> Date: Fri Nov 8 09:02:30 2013 +0100 Fix coverage.test: instrumented-source-files * test-suite/tests/coverage.test ("instrumented-source-files"): Adapt to new expectation that all files loaded on the system will be present in the source information. commit 697c4f29d93bb3b9dc44a666cf2e1b585f070da9 Author: Andy Wingo <[email protected]> Date: Fri Nov 8 09:00:06 2013 +0100 Fix coverage.test: "procedure-execution-count: never" * test-suite/tests/coverage.test ("procedure-execution-count"): Adapt test to new behavior of procedure-execution-count of an unseen procedure: zero, not false. commit 7a5a533595ec3df028adea46eebeb76f72c832ec Author: Andy Wingo <[email protected]> Date: Fri Nov 8 08:56:52 2013 +0100 Fix coverage.test: "line-execution-counts: one proc hit, one proc unused" * test-suite/tests/coverage.test ("line-execution-counts"): Fix test for even/odd? in letrec. The test profiles the execution of even?, not the letrec, so the last line is in fact not reached. ----------------------------------------------------------------------- Summary of changes: libguile/gsubr.c | 4 +- libguile/gsubr.h | 2 +- libguile/programs.c | 2 +- libguile/vm-engine.c | 241 +++++++++++++++++++-------------- module/ice-9/eval.scm | 2 +- module/language/cps/contification.scm | 14 ++- module/system/vm/assembler.scm | 9 +- module/system/vm/debug.scm | 18 ++- module/system/vm/program.scm | 13 +- test-suite/tests/coverage.test | 11 +- test-suite/tests/eval.test | 4 +- 11 files changed, 182 insertions(+), 138 deletions(-) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 5dd767d..96fab4e 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -286,7 +286,7 @@ scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest) return 1; } -int +scm_t_uintptr scm_i_primitive_call_ip (SCM subr) { const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (subr); @@ -294,7 +294,7 @@ scm_i_primitive_call_ip (SCM subr) /* A stub is 4 32-bit words long, or 16 bytes. The call will be one instruction, in either the fourth, third, or second word. Return a byte offset from the entry. */ - return code[3] ? 12 : code[2] ? 8 : 4; + return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1)); } SCM diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 6bdfe6b..3350e2f 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -55,7 +55,7 @@ SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest); -SCM_INTERNAL int scm_i_primitive_call_ip (SCM subr); +SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr); SCM_API SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, scm_t_subr fcn); diff --git a/libguile/programs.c b/libguile/programs.c index 3e228f7..f74e4ed 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -248,7 +248,7 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0, { SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P); - return scm_from_int (scm_i_primitive_call_ip (prim)); + return scm_from_uintptr_t (scm_i_primitive_call_ip (prim)); } #undef FUNC_NAME diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index a403524..567bdbc 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -668,7 +668,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) } while (0) #define BR_NARGS(rel) \ - scm_t_uint16 expected; \ + scm_t_uint32 expected; \ SCM_UNPACK_RTL_24 (op, expected); \ if (FRAME_LOCALS_COUNT() rel expected) \ { \ @@ -1564,6 +1564,41 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } + /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24 + * + * Find the first positional argument after NREQ. If it is greater + * than NPOS, jump to OFFSET. + * + * This instruction is only emitted for functions with multiple + * clauses, and an earlier clause has keywords and no rest arguments. + * See "Case-lambda" in the manual, for more on how case-lambda + * chooses the clause to apply. + */ + VM_DEFINE_OP (25, br_if_npos_gt, "br-if-npos-gt", OP3 (U8_U24, X8_U24, X8_L24)) + { + scm_t_uint32 nreq, npos; + + SCM_UNPACK_RTL_24 (op, nreq); + SCM_UNPACK_RTL_24 (ip[1], npos); + + /* We can only have too many positionals if there are more + arguments than NPOS. */ + if (FRAME_LOCALS_COUNT() > npos) + { + scm_t_uint32 n; + for (n = nreq; n < npos; n++) + if (scm_is_keyword (LOCAL_REF (n))) + break; + if (n == npos && !scm_is_keyword (LOCAL_REF (n))) + { + scm_t_int32 offset = ip[2]; + offset >>= 8; /* Sign-extending shift. */ + NEXT (offset); + } + } + NEXT (3); + } + /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24 * _:8 ntotal:24 kw-offset:32 * @@ -1576,7 +1611,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * A macro-mega-instruction. */ - VM_DEFINE_OP (25, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32)) + VM_DEFINE_OP (26, 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; @@ -1662,7 +1697,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 (26, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST) + VM_DEFINE_OP (27, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST) { scm_t_uint32 dst, nargs; SCM rest = SCM_EOL; @@ -1704,7 +1739,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 (27, br, "br", OP1 (U8_L24)) + VM_DEFINE_OP (28, br, "br", OP1 (U8_L24)) { scm_t_int32 offset = op; offset >>= 8; /* Sign-extending shift. */ @@ -1716,7 +1751,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 (28, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (29, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_true (x)); } @@ -1726,7 +1761,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 (29, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (30, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_null (x)); } @@ -1736,7 +1771,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 (30, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (31, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_lisp_false (x)); } @@ -1746,7 +1781,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 (31, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (32, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_pair (x)); } @@ -1756,7 +1791,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 (32, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (33, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, SCM_STRUCTP (x)); } @@ -1766,7 +1801,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 (33, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (34, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, SCM_CHARP (x)); } @@ -1776,7 +1811,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 (34, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24)) + VM_DEFINE_OP (35, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24)) { BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f)); } @@ -1786,7 +1821,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 (35, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (36, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y)); } @@ -1796,7 +1831,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 (36, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (37, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1811,7 +1846,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 (37, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (38, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1824,7 +1859,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_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (39, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (==, scm_num_eq_p); } @@ -1834,7 +1869,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_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (40, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (<, scm_less_p); } @@ -1844,7 +1879,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 (40, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (41, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (<=, scm_leq_p); } @@ -1860,7 +1895,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, mov, "mov", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (42, mov, "mov", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst; scm_t_uint16 src; @@ -1875,7 +1910,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Copy a value from one local slot to another. */ - VM_DEFINE_OP (42, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST) + VM_DEFINE_OP (43, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST) { scm_t_uint32 dst; scm_t_uint32 src; @@ -1891,7 +1926,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 (43, box, "box", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (44, box, "box", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); @@ -1904,7 +1939,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; @@ -1922,7 +1957,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)) + VM_DEFINE_OP (46, box_set, "box-set!", OP1 (U8_U12_U12)) { scm_t_uint16 dst, src; SCM var; @@ -1941,7 +1976,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 (46, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST) + VM_DEFINE_OP (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST) { scm_t_uint32 dst, nfree, n; scm_t_int32 offset; @@ -1965,7 +2000,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 (47, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST) + VM_DEFINE_OP (48, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -1980,7 +2015,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 (48, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24)) + VM_DEFINE_OP (49, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24)) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -2003,7 +2038,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; @@ -2018,7 +2053,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_uint32 dst; scm_t_bits val; @@ -2033,7 +2068,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_uint32 dst; scm_t_bits val; @@ -2064,7 +2099,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; @@ -2093,7 +2128,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; @@ -2116,7 +2151,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; @@ -2138,7 +2173,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * are signed 32-bit values, indicating a memory address as a number * of 32-bit words away from the current instruction pointer. */ - VM_DEFINE_OP (55, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32)) + VM_DEFINE_OP (56, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32)) { scm_t_int32 dst_offset, src_offset; void *src; @@ -2196,7 +2231,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; @@ -2213,7 +2248,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 (57, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST) + VM_DEFINE_OP (58, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST) { scm_t_uint32 dst; scm_t_uint32 sym; @@ -2237,7 +2272,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 (58, define, "define!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (59, define, "define!", OP1 (U8_U12_U12)) { scm_t_uint16 sym, val; SCM_UNPACK_RTL_12_12 (op, sym, val); @@ -2265,7 +2300,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 (59, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST) + VM_DEFINE_OP (60, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -2317,7 +2352,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 (60, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST) + VM_DEFINE_OP (61, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -2387,7 +2422,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 (61, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24)) + VM_DEFINE_OP (62, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24)) { scm_t_uint32 tag, proc_slot; scm_t_int32 offset; @@ -2419,7 +2454,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 (62, wind, "wind", OP1 (U8_U12_U12)) + VM_DEFINE_OP (63, wind, "wind", OP1 (U8_U12_U12)) { scm_t_uint16 winder, unwinder; SCM_UNPACK_RTL_12_12 (op, winder, unwinder); @@ -2433,7 +2468,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 (63, unwind, "unwind", OP1 (U8_X24)) + VM_DEFINE_OP (64, unwind, "unwind", OP1 (U8_X24)) { scm_dynstack_pop (¤t_thread->dynstack); NEXT (1); @@ -2445,7 +2480,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 (64, push_fluid, "push-fluid", OP1 (U8_U12_U12)) + VM_DEFINE_OP (65, push_fluid, "push-fluid", OP1 (U8_U12_U12)) { scm_t_uint32 fluid, value; @@ -2462,7 +2497,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 (65, pop_fluid, "pop-fluid", OP1 (U8_X24)) + VM_DEFINE_OP (66, pop_fluid, "pop-fluid", OP1 (U8_X24)) { /* This function must not allocate. */ scm_dynstack_unwind_fluid (¤t_thread->dynstack, @@ -2474,7 +2509,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 (66, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (67, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; size_t num; @@ -2507,7 +2542,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 (67, fluid_set, "fluid-set", OP1 (U8_U12_U12)) + VM_DEFINE_OP (68, fluid_set, "fluid-set", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; size_t num; @@ -2540,7 +2575,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 (68, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (69, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (str); if (SCM_LIKELY (scm_is_string (str))) @@ -2557,7 +2592,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 (69, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (70, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (str, idx); @@ -2579,7 +2614,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 (70, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (71, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; @@ -2595,7 +2630,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 (71, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (72, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; @@ -2609,7 +2644,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 (72, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (73, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); @@ -2628,7 +2663,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 (73, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (74, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN (scm_cons (x, y)); @@ -2638,7 +2673,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the car of SRC in DST. */ - VM_DEFINE_OP (74, car, "car", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (75, car, "car", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "car"); @@ -2649,7 +2684,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the cdr of SRC in DST. */ - VM_DEFINE_OP (75, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (76, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "cdr"); @@ -2660,7 +2695,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Set the car of DST to SRC. */ - VM_DEFINE_OP (76, set_car, "set-car!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (77, set_car, "set-car!", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; SCM x, y; @@ -2676,7 +2711,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Set the cdr of DST to SRC. */ - VM_DEFINE_OP (77, set_cdr, "set-cdr!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (78, set_cdr, "set-cdr!", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; SCM x, y; @@ -2699,7 +2734,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 (78, add, "add", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (79, add, "add", OP1 (U8_U8_U8_U8) | OP_DST) { BINARY_INTEGER_OP (+, scm_sum); } @@ -2708,7 +2743,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 (79, add1, "add1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (80, add1, "add1", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); @@ -2733,7 +2768,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 (80, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (81, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST) { BINARY_INTEGER_OP (-, scm_difference); } @@ -2742,7 +2777,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 (81, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (82, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); @@ -2767,7 +2802,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 (82, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (83, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2778,7 +2813,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 (83, div, "div", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (84, div, "div", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2789,7 +2824,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 (84, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (85, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2800,7 +2835,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 (85, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (86, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2811,7 +2846,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 (86, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (87, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2822,7 +2857,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 (87, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (88, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2858,7 +2893,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 (88, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (89, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2872,7 +2907,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 (89, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (90, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2886,7 +2921,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 (90, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (91, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2900,7 +2935,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Make a vector and write it to DST. The vector will have space for * LENGTH slots. They will be filled with the value in slot INIT. */ - VM_DEFINE_OP (91, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (92, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, length, init; @@ -2917,7 +2952,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * will have space for LENGTH slots, an immediate value. They will be * filled with the value in slot INIT. */ - VM_DEFINE_OP (92, constant_make_vector, "constant-make-vector", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (93, constant_make_vector, "constant-make-vector", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, init; scm_t_int32 length, n; @@ -2937,7 +2972,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 (93, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (94, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (vect); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) @@ -2954,7 +2989,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 (94, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (95, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (vect, idx); @@ -2975,7 +3010,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 (95, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (96, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM v; @@ -2994,7 +3029,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 (96, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (97, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx_var, src; SCM vect, idx, val; @@ -3023,7 +3058,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Store SRC into the vector DST at index IDX. Here IDX is an * immediate value. */ - VM_DEFINE_OP (97, constant_vector_set, "constant-vector-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (98, constant_vector_set, "constant-vector-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM vect, val; @@ -3054,7 +3089,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (98, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (99, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); VM_VALIDATE_STRUCT (obj, "struct_vtable"); @@ -3067,7 +3102,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 (99, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (100, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, vtable, nfields; SCM ret; @@ -3086,7 +3121,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 (100, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (101, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (obj, pos); @@ -3120,7 +3155,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 (101, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (102, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM obj, pos, val; @@ -3161,7 +3196,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (102, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (103, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); if (SCM_INSTANCEP (obj)) @@ -3176,7 +3211,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 (103, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (104, 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); @@ -3190,7 +3225,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 (104, slot_set, "slot-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (105, 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); @@ -3211,7 +3246,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 (105, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST) + VM_DEFINE_OP (106, 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; @@ -3231,7 +3266,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 (106, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST) + VM_DEFINE_OP (107, 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); @@ -3329,42 +3364,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 (107, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (u8, u8, uint8, 1); - VM_DEFINE_OP (108, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (s8, s8, int8, 1); - VM_DEFINE_OP (109, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (110, 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 (110, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (111, 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 (111, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (112, 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 (112, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (113, 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 (113, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_INT_REF (u64, uint64, 8); - VM_DEFINE_OP (114, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_INT_REF (s64, int64, 8); - VM_DEFINE_OP (115, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FLOAT_REF (f32, ieee_single, float, 4); - VM_DEFINE_OP (116, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (117, 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 @@ -3468,42 +3503,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); \ } while (0) - VM_DEFINE_OP (117, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (118, 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 (118, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (119, 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 (119, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (120, 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 (120, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (121, 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 (121, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (122, 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 (122, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (123, 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 (123, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) BV_INT_SET (u64, uint64, 8); - VM_DEFINE_OP (124, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) BV_INT_SET (s64, int64, 8); - VM_DEFINE_OP (125, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) BV_FLOAT_SET (f32, ieee_single, float, 4); - VM_DEFINE_OP (126, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (127, 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/ice-9/eval.scm b/module/ice-9/eval.scm index 51cdb65..f95bbe9 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -384,7 +384,7 @@ (cond ((or (< nargs nreq) (and (not kw) (not rest?) (> nargs (+ nreq nopt))) - (and kw (not rest?) (> (npositional %args) (+ nreq nopt)))) + (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt)))) (if alt (apply alt-proc %args) ((scm-error 'wrong-number-of-args diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index 6e8fe62..7a9252e 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -84,11 +84,15 @@ ;; Are the given args compatible with any of the arities? (define (applicable? proc args) - (or-map (match-lambda - (($ $arity req () #f () #f) - (= (length args) (length req))) - (_ #f)) - (assq-ref (map cons syms arities) proc))) + (let lp ((arities (assq-ref (map cons syms arities) proc))) + (match arities + ((($ $arity req () #f () #f) . arities) + (or (= (length args) (length req)) + (lp arities))) + ;; If we reached the end of the arities, fail. Also fail if + ;; the next arity in the list has optional, keyword, or rest + ;; arguments. + (_ #f)))) ;; If the use of PROC in continuation USE is a call to PROC that ;; is compatible with one of the procedure's arities, return the diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index d6b417f..58c00ef 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -791,7 +791,10 @@ returned instead." (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) + (begin + (emit-br-if-nargs-lt asm nreq alternate) + (unless rest? + (emit-br-if-npos-gt asm nreq (+ nreq nopt) alternate))) (emit-assert-nargs-ge asm nreq)) (let ((ntotal (fold (lambda (kw ntotal) (match kw @@ -1380,8 +1383,8 @@ it will be added to the GC roots at runtime." (define (write-arity-headers metas bv endianness) (define (write-arity-header* pos low-pc high-pc flags nreq nopt) - (bytevector-u32-set! bv pos low-pc endianness) - (bytevector-u32-set! bv (+ pos 4) high-pc endianness) + (bytevector-u32-set! bv pos (* low-pc 4) endianness) + (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness) (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset (bytevector-u32-set! bv (+ pos 12) flags endianness) (bytevector-u32-set! bv (+ pos 16) nreq endianness) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index a3aede7..5611432 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -272,12 +272,18 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3))))) (define (arity-low-pc arity) - (arity-low-pc* (elf-bytes (debug-context-elf (arity-context arity))) - (arity-header-offset arity))) + (let ((ctx (arity-context arity))) + (+ (debug-context-base ctx) + (debug-context-text-base ctx) + (arity-low-pc* (elf-bytes (debug-context-elf ctx)) + (arity-header-offset arity))))) (define (arity-high-pc arity) - (arity-high-pc* (elf-bytes (debug-context-elf (arity-context arity))) - (arity-header-offset arity))) + (let ((ctx (arity-context arity))) + (+ (debug-context-base ctx) + (debug-context-text-base ctx) + (arity-high-pc* (elf-bytes (debug-context-elf ctx)) + (arity-header-offset arity))))) (define (arity-nreq arity) (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity))) @@ -352,9 +358,9 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (let lp ((pos headers-start)) (cond ((>= pos headers-end) #f) - ((< text-offset (* (arity-low-pc* bv pos) 4)) + ((< text-offset (arity-low-pc* bv pos)) #f) - ((<= (* (arity-high-pc* bv pos) 4) text-offset) + ((<= (arity-high-pc* bv pos) text-offset) (lp (+ pos arity-header-len))) (else (make-arity context base pos)))))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index ecac6a7..cf77c28 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -314,13 +314,12 @@ prog (list 0 0 nreq nopt rest? '(#f . ())))))))) ((rtl-program? prog) - (let ((pc (and ip (+ (rtl-program-code prog) ip)))) - (or-map (lambda (arity) - (and (or (not pc) - (and (<= (arity-low-pc arity) pc) - (< pc (arity-high-pc arity)))) - (arity-arguments-alist arity))) - (or (find-program-arities (rtl-program-code prog)) '())))) + (or-map (lambda (arity) + (and (or (not ip) + (and (<= (arity-low-pc arity) ip) + (< ip (arity-high-pc arity)))) + (arity-arguments-alist arity))) + (or (find-program-arities (rtl-program-code prog)) '()))) (else (let ((arity (program-arity prog ip))) (and arity diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test index 336c87a..7a7a6c5 100644 --- a/test-suite/tests/coverage.test +++ b/test-suite/tests/coverage.test @@ -156,10 +156,9 @@ (let ((line (car line+count)) (count (cdr line+count))) (case line - ((0 1) (= count 1)) - ((2 3 4) (= count 0)) - ((5) (= count 1)) - (else #f)))) + ((0 1) (= count 1)) + ((2 3 4 5) (= count 0)) + (else #f)))) counts)))))) (pass-if "case-lambda" @@ -214,7 +213,7 @@ (lambda () (+ 1 2))))) (and (coverage-data? data) (= 3 result) - (not (procedure-execution-count data proc)))))) + (zero? (procedure-execution-count data proc)))))) (pass-if "applicable struct" (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw)) @@ -268,4 +267,4 @@ (let ((files (map basename (instrumented-source-files data)))) (and (member "boot-9.scm" files) (member "chbouib.scm" files) - (not (member "foo.scm" files)))))))) + #t)))))) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index a0221b8..8930cf2 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -349,9 +349,7 @@ (define tag (make-prompt-tag "foo")) (with-test-prefix "stacks" - ;; FIXME: Until we get one VM, a call to an RTL primitive from the - ;; stack VM will result in the primitive being on the stack twice. - (expect-fail "stack involving a primitive" + (pass-if "stack involving a primitive" ;; The primitive involving the error must appear exactly once on the ;; stack. (let* ((stack (make-tagged-trimmed-stack tag '(#t))) hooks/post-receive -- GNU Guile
