guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-354


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-354-gb0ed216
Date: Fri, 08 Nov 2013 11:50:23 +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=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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 <address@hidden>
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 (&current_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 (&current_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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]