guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-253-gd724a36


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-253-gd724a36
Date: Fri, 18 Oct 2013 09:49:46 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d724a36562357c86f2b4c21b46992abf9598b4d1

The branch, master has been updated
       via  d724a36562357c86f2b4c21b46992abf9598b4d1 (commit)
       via  27337b6373954e1a975d97d0bf06b5c03d65b64d (commit)
       via  9dff1df97f7021b1d2edd5dd73d1ca426def943b (commit)
       via  919f304fb29186302657c23f0702110075440291 (commit)
      from  361d0de285587ef4c9f19b9e07c1175424520aa5 (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 d724a36562357c86f2b4c21b46992abf9598b4d1
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 18 11:47:05 2013 +0200

    Fix statprof-proc-call-data for recent changes
    
    * module/statprof.scm (statprof-proc-call-data): Fix statprof for recent
      fixes.

commit 27337b6373954e1a975d97d0bf06b5c03d65b64d
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 18 10:03:26 2013 +0200

    Subrs are RTL programs
    
    * libguile/gsubr.c: Define RTL stubs instead of stack VM stubs.
      (SUBR_STUB_CODE, get_subr_stub_code): Adapt to return a uint32_t*
      pointer instead of a SCM value.
      (create_subr): Create RTL procedures instead of stack VM procedures.
      For RTL procedures, the function pointer, name, and generic address
      pointer go inline to the procedure, as free variables.
      (scm_i_primitive_arity, scm_i_primitive_call_ip): New helpers.
      (scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic)
      (scm_c_define_gsubr_with_generic): Adapt to create_gsubr being renamed
      to create_subr.
    
      Remove gsubr test code.
    
    * libguile/gsubr.h (SCM_PRIMITIVE_P, SCM_PRIMITIVE_GENERIC_P): Only RTL
      programs can be primitives now.
      (SCM_SUBRF, SCM_SUBR_NAME, SCM_SUBR_GENERIC): These fields are now in
      the RTL free variables, not the object table.
    
    * libguile/programs.c (scm_i_rtl_program_name):
      (scm_i_rtl_program_documentation):
      (scm_i_rtl_program_properties):
      (scm_i_rtl_program_minimum_arity): Implement these appropriately for
      primitives, which lack debugging information.
      (scm_primitive_p, scm_primitive_call_ip): New helpers.
    
    * libguile/snarf.h: Remove static allocation for subrs.  Since there is
      nothing to allocate besides the program itself, which needs runtime
      relocation, static allocation is not a win.
    
    * system/vm/program.scm: Fix up various arity-related things for
      primitives, which don't use ELF arity info.
    
    * test-suite/tests/eval.test ("stack involving a primitive"): Add an
      XFAIL until we get just one VM.

commit 9dff1df97f7021b1d2edd5dd73d1ca426def943b
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 18 11:38:36 2013 +0200

    (system vm debug): implement arity-low-pc, arity-high-pc
    
    * module/system/vm/debug.scm (arity-low-pc, arity-high-pc): Implement
      these exports.

commit 919f304fb29186302657c23f0702110075440291
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 18 09:45:53 2013 +0200

    class-of fix for RTL programs
    
    * libguile/goops.c (scm_class_of): Use the same logic for RTL programs
      and stack VM programs.

-----------------------------------------------------------------------

Summary of changes:
 libguile/goops.c             |   11 +-
 libguile/gsubr.c             |  819 +++++++-----------------------------------
 libguile/gsubr.h             |   23 +-
 libguile/programs.c          |   37 ++
 libguile/programs.h          |    3 +
 libguile/snarf.h             |   41 +--
 module/statprof.scm          |    2 +-
 module/system/vm/debug.scm   |    8 +
 module/system/vm/program.scm |   38 ++-
 test-suite/tests/eval.test   |    6 +-
 10 files changed, 239 insertions(+), 749 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 74ded73..49840bf 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
+/* Copyright (C) 
1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -295,15 +295,18 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
            return scm_class_fraction;
           }
        case scm_tc7_program:
+       case scm_tc7_rtl_program:
+          /* Although SCM_SUBR_GENERIC is specific to stack programs
+             currently, in practice only stack programs pass
+             SCM_PROGRAM_IS_PRIMITIVE_GENERIC.  In the future this will
+             change to be the other way around, when subrs become RTL
+             programs.  */
          if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
               && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
            return scm_class_primitive_generic;
          else
            return scm_class_procedure;
 
-       case scm_tc7_rtl_program:
-          return scm_class_procedure;
-
        case scm_tc7_smob:
          {
            scm_t_bits type = SCM_TYP16 (x);
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 84846cf..4e061e3 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 
2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 
2011, 2013 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -40,8 +40,6 @@
  * and rest arguments.
  */
 
-/* #define GSUBR_TEST */
-
 
 
 /* OK here goes nothing: we're going to define VM assembly trampolines for
@@ -75,131 +73,79 @@
    read-only data.
 */
 
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
-#define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
-#define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
-#endif
-
 /* A: req; B: opt; C: rest */
 #define A(nreq)                                                         \
-  OBJCODE_HEADER,                                                       \
-  /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
-  /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr 
pointer */ \
-  /* 5 */ scm_op_subr_call, nreq, /* and call (will return value as well) */ \
-  /* 7 */ scm_op_nop,                                                   \
-  /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
-  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
-  /* 16 */ META (3, 7, nreq, 0, 0)
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, nreq + 1),               \
+  SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
+  0,                                                                    \
+  0
 
 #define B(nopt)                                                         \
-  OBJCODE_HEADER,                                                       \
-  /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
-  /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */  \
-  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr 
pointer */ \
-  /* 8 */ scm_op_subr_call, nopt, /* and call (will return value as well) */ \
-  /* 10 */ scm_op_nop, scm_op_nop,                                      \
-  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
-  /* 16 */ META (6, 10, 0, nopt, 0)
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nopt + 1),               \
+  SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nopt + 1),                   \
+  SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
+  0
 
 #define C()                                                             \
-  OBJCODE_HEADER,                                                       \
-  /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */       \
-  /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr 
pointer */ \
-  /* 5 */ scm_op_subr_call, 1, /* and call (will return value as well) */ \
-  /* 7 */ scm_op_nop,                                                   \
-  /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
-  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
-  /* 16 */ META (3, 7, 0, 0, 1)
+  SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, 1),                            \
+  SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
+  0,                                                                    \
+  0
 
 #define AB(nreq, nopt)                                                  \
-  OBJCODE_HEADER,                                                       \
-  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
-  /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
-  /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
-  /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr 
pointer */ \
-  /* 11 */ scm_op_subr_call, nreq+nopt, /* and call (will return value as 
well) */ \
-  /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
-  /* 16 */ META (9, 13, nreq, nopt, 0)
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1),               \
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nreq + nopt + 1),        \
+  SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nreq + nopt + 1),            \
+  SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0)
 
 #define AC(nreq)                                                        \
-  OBJCODE_HEADER,                                                       \
-  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
-  /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */               \
-  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr 
pointer */ \
-  /* 8 */ scm_op_subr_call, nreq+1, /* and call (will return value as well) */ 
\
-  /* 10 */ scm_op_nop, scm_op_nop,                                      \
-  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
-  /* 16 */ META (6, 10, nreq, 0, 1)
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1),               \
+  SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + 1),                     \
+  SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
+  0
 
 #define BC(nopt)                                                        \
-  OBJCODE_HEADER,                                                       \
-  /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
-  /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */               \
-  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr 
pointer */ \
-  /* 8 */ scm_op_subr_call, nopt+1, /* and call (will return value as well) */ 
\
-  /* 10 */ scm_op_nop, scm_op_nop,                                      \
-  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
-  /* 16 */ META (6, 10, 0, nopt, 1)
+  SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nopt + 1),                     \
+  SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
+  0,                                                                    \
+  0
 
 #define ABC(nreq, nopt)                                                 \
-  OBJCODE_HEADER,                                                       \
-  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
-  /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
-  /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */          \
-  /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr 
pointer */ \
-  /* 11 */ scm_op_subr_call, nreq+nopt+1, /* and call (will return value as 
well) */ \
-  /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
-  /* 16 */ META (9, 13, nreq, nopt, 1)
-  
-#define META(start, end, nreq, nopt, rest)                              \
-  META_HEADER,                                                          \
-  /* 0 */ scm_op_make_eol, /* bindings */                               \
-  /* 1 */ scm_op_make_eol, /* sources */                                \
-  /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N 
to ip N */ \
-  /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
-  /* 8 */ scm_op_make_int8, nopt, /* N optionals */                     \
-  /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ 
\
-  /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */         \
-  /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one 
list */ \
-  /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
-  /* 25 */ scm_op_object_ref, 1, /* the name from the object table */   \
-  /* 27 */ scm_op_cons, /* make a pair for the properties */            \
-  /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list 
*/ \
-  /* 31 */ scm_op_return /* and return */                               \
-  /* 32 */
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1),               \
+  SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + nopt + 1),              \
+  SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
+  0
+
 
 /*
  (defun generate-bytecode (n)
    "Generate bytecode for N arguments"
    (interactive "p")
-   (insert (format "/\* %d arguments *\/\n  " n))
+   (insert (format "/\* %d arguments *\/\n " n))
    (let ((nreq n))
      (while (<= 0 nreq)
        (let ((nopt (- n nreq)))
          (insert
           (if (< 0 nreq)
               (if (< 0 nopt)
-                  (format "AB(%d,%d), " nreq nopt)
-                  (format "A(%d), " nreq))
+                  (format " AB(%d,%d)," nreq nopt)
+                  (format " A(%d)," nreq))
               (if (< 0 nopt)
-                  (format "B(%d), " nopt)
-                  (format "A(0), "))))
+                  (format " B(%d)," nopt)
+                  (format " A(0),"))))
          (setq nreq (1- nreq))))
-     (insert "\n  ")
+     (insert "\n ")
      (setq nreq (1- n))
      (while (<= 0 nreq)
        (let ((nopt (- n nreq 1)))
          (insert
           (if (< 0 nreq)
               (if (< 0 nopt)
-                  (format "ABC(%d,%d), " nreq nopt)
-                  (format "AC(%d), " nreq))
+                  (format " ABC(%d,%d)," nreq nopt)
+                  (format " AC(%d)," nreq))
               (if (< 0 nopt)
-                  (format "BC(%d), " nopt)
-                  (format "C(), "))))
+                  (format " BC(%d)," nopt)
+                  (format " C(),"))))
          (setq nreq (1- nreq))))
      (insert "\n\n  ")))
 
@@ -211,621 +157,156 @@
        (generate-bytecode i)
        (setq i (1+ i)))))
 */
-static const struct
-{
-  scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way 
*/
-  const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16
-                                 + sizeof (struct scm_objcode) + 32)];
-} raw_bytecode = {
-  0,
-  {
-    /* C-u 1 0 M-x generate-bytecodes RET */
-    /* 0 arguments */
-    A(0), 
-  
-    /* 1 arguments */
-    A(1), B(1), 
-    C(), 
-
-    /* 2 arguments */
-    A(2), AB(1,1), B(2), 
-    AC(1), BC(1), 
-
-    /* 3 arguments */
-    A(3), AB(2,1), AB(1,2), B(3), 
-    AC(2), ABC(1,1), BC(2), 
-
-    /* 4 arguments */
-    A(4), AB(3,1), AB(2,2), AB(1,3), B(4), 
-    AC(3), ABC(2,1), ABC(1,2), BC(3), 
-
-    /* 5 arguments */
-    A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5), 
-    AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4), 
-
-    /* 6 arguments */
-    A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6), 
-    AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5), 
-
-    /* 7 arguments */
-    A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7), 
-    AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6), 
-
-    /* 8 arguments */
-    A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8), 
-    AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7), 
-
-    /* 9 arguments */
-    A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), 
AB(1,8), B(9), 
-    AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), 
ABC(1,7), BC(8), 
-
-    /* 10 arguments */
-    A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), 
AB(2,8), AB(1,9), B(10), 
-    AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), 
ABC(2,7), ABC(1,8), BC(9)
-  }
-};
-
-#undef A
-#undef B
-#undef C
-#undef AB
-#undef AC
-#undef BC
-#undef ABC
-#undef OBJCODE_HEADER
-#undef META_HEADER
-#undef META
-
-/*
- ;; (nargs * nargs) + nopt + rest * (nargs + 1)
- (defun generate-objcode-cells-helper (n)
-   "Generate objcode cells for N arguments"
-   (interactive "p")
-   (insert (format "    /\* %d arguments *\/\n" n))
-   (let ((nreq n))
-     (while (<= 0 nreq)
-       (let ((nopt (- n nreq)))
-         (insert
-          (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 
%d) },\n"
-                  (* (+ 4 4 16 4 4 32)
-                     (+ (* n n) nopt))))
-         (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
-         (setq nreq (1- nreq))))
-     (insert "\n")
-     (setq nreq (1- n))
-     (while (<= 0 nreq)
-       (let ((nopt (- n nreq 1)))
-         (insert
-          (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 
%d) },\n"
-                  (* (+ 4 4 16 4 4 32)
-                     (+ (* n n) nopt n 1))))
-         (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
-         (setq nreq (1- nreq))))
-     (insert "\n")))
-
- (defun generate-objcode-cells (n)
-   "Generate objcode cells for up to N arguments"
-   (interactive "p")
-   (let ((i 0))
-     (while (<= i n)
-       (generate-objcode-cells-helper i)
-       (setq i (1+ i)))))
-*/
-
-#define STATIC_OBJCODE_TAG                                      \
-  SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
-
-static const struct
-{
-  scm_t_uint64 dummy; /* alignment */
-  scm_t_cell cells[121 * 2]; /* 11*11 double cells */
-} objcode_cells = {
-  0,
-  /* C-u 1 0 M-x generate-objcode-cells RET */
-  {
-    /* 0 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-
-    /* 1 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 2 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 3 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 4 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1024) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1088) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1152) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1216) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1280) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1344) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1408) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1472) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1536) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 5 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1600) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1664) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1728) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1792) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1856) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1920) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1984) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2048) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2112) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2176) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2240) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 6 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2304) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2368) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2432) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2496) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2560) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2624) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2688) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2752) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2816) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2880) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2944) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3008) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3072) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 7 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3136) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3200) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3264) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3328) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3392) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3456) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3520) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3584) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3648) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3712) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3776) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3840) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3904) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3968) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4032) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 8 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4096) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4160) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4224) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4288) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4352) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4416) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4480) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4544) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4608) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4672) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4736) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4800) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4864) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4928) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4992) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5056) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5120) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 9 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5184) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5248) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5312) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5376) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5440) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5504) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5568) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5632) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5696) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5760) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5824) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5888) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5952) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6016) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6080) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6144) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6208) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6272) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6336) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    /* 10 arguments */
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6400) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6464) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6528) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6592) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6656) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6720) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6784) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6848) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6912) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6976) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7040) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7104) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7168) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7232) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7296) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7360) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7424) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7488) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7552) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7616) },
-    { SCM_BOOL_F, SCM_PACK (0) },
-    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7680) },
-    { SCM_BOOL_F, SCM_PACK (0) }
-  }
-};
-  
-/*
- (defun generate-objcode (n)
-   "Generate objcode for N arguments"
-   (interactive "p")
-   (insert (format "  /\* %d arguments *\/\n" n))
-   (let ((i (* n n)))
-     (while (< i (* (1+ n) (1+ n)))
-       (insert (format "  SCM_PACK (objcode_cells.cells+%d),\n" (* i 2)))
-       (setq i (1+ i)))
-     (insert "\n")))
-
- (defun generate-objcodes (n)
-   "Generate objcodes for up to N arguments"
-   (interactive "p")
-   (let ((i 0))
-     (while (<= i n)
-       (generate-objcode i)
-       (setq i (1+ i)))))
-*/
-static const SCM scm_subr_objcode_trampolines[121] = {
-  /* C-u 1 0 M-x generate-objcodes RET */
+static const scm_t_uint32 subr_stub_code[] = {
+  /* C-u 1 0 M-x generate-bytecodes RET */
   /* 0 arguments */
-  SCM_PACK (objcode_cells.cells+0),
+  A(0),
 
   /* 1 arguments */
-  SCM_PACK (objcode_cells.cells+2),
-  SCM_PACK (objcode_cells.cells+4),
-  SCM_PACK (objcode_cells.cells+6),
+  A(1), B(1),
+  C(),
 
   /* 2 arguments */
-  SCM_PACK (objcode_cells.cells+8),
-  SCM_PACK (objcode_cells.cells+10),
-  SCM_PACK (objcode_cells.cells+12),
-  SCM_PACK (objcode_cells.cells+14),
-  SCM_PACK (objcode_cells.cells+16),
+  A(2), AB(1,1), B(2),
+  AC(1), BC(1),
 
   /* 3 arguments */
-  SCM_PACK (objcode_cells.cells+18),
-  SCM_PACK (objcode_cells.cells+20),
-  SCM_PACK (objcode_cells.cells+22),
-  SCM_PACK (objcode_cells.cells+24),
-  SCM_PACK (objcode_cells.cells+26),
-  SCM_PACK (objcode_cells.cells+28),
-  SCM_PACK (objcode_cells.cells+30),
+  A(3), AB(2,1), AB(1,2), B(3),
+  AC(2), ABC(1,1), BC(2),
 
   /* 4 arguments */
-  SCM_PACK (objcode_cells.cells+32),
-  SCM_PACK (objcode_cells.cells+34),
-  SCM_PACK (objcode_cells.cells+36),
-  SCM_PACK (objcode_cells.cells+38),
-  SCM_PACK (objcode_cells.cells+40),
-  SCM_PACK (objcode_cells.cells+42),
-  SCM_PACK (objcode_cells.cells+44),
-  SCM_PACK (objcode_cells.cells+46),
-  SCM_PACK (objcode_cells.cells+48),
+  A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
+  AC(3), ABC(2,1), ABC(1,2), BC(3),
 
   /* 5 arguments */
-  SCM_PACK (objcode_cells.cells+50),
-  SCM_PACK (objcode_cells.cells+52),
-  SCM_PACK (objcode_cells.cells+54),
-  SCM_PACK (objcode_cells.cells+56),
-  SCM_PACK (objcode_cells.cells+58),
-  SCM_PACK (objcode_cells.cells+60),
-  SCM_PACK (objcode_cells.cells+62),
-  SCM_PACK (objcode_cells.cells+64),
-  SCM_PACK (objcode_cells.cells+66),
-  SCM_PACK (objcode_cells.cells+68),
-  SCM_PACK (objcode_cells.cells+70),
+  A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
+  AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
 
   /* 6 arguments */
-  SCM_PACK (objcode_cells.cells+72),
-  SCM_PACK (objcode_cells.cells+74),
-  SCM_PACK (objcode_cells.cells+76),
-  SCM_PACK (objcode_cells.cells+78),
-  SCM_PACK (objcode_cells.cells+80),
-  SCM_PACK (objcode_cells.cells+82),
-  SCM_PACK (objcode_cells.cells+84),
-  SCM_PACK (objcode_cells.cells+86),
-  SCM_PACK (objcode_cells.cells+88),
-  SCM_PACK (objcode_cells.cells+90),
-  SCM_PACK (objcode_cells.cells+92),
-  SCM_PACK (objcode_cells.cells+94),
-  SCM_PACK (objcode_cells.cells+96),
+  A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
+  AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
 
   /* 7 arguments */
-  SCM_PACK (objcode_cells.cells+98),
-  SCM_PACK (objcode_cells.cells+100),
-  SCM_PACK (objcode_cells.cells+102),
-  SCM_PACK (objcode_cells.cells+104),
-  SCM_PACK (objcode_cells.cells+106),
-  SCM_PACK (objcode_cells.cells+108),
-  SCM_PACK (objcode_cells.cells+110),
-  SCM_PACK (objcode_cells.cells+112),
-  SCM_PACK (objcode_cells.cells+114),
-  SCM_PACK (objcode_cells.cells+116),
-  SCM_PACK (objcode_cells.cells+118),
-  SCM_PACK (objcode_cells.cells+120),
-  SCM_PACK (objcode_cells.cells+122),
-  SCM_PACK (objcode_cells.cells+124),
-  SCM_PACK (objcode_cells.cells+126),
+  A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
+  AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
 
   /* 8 arguments */
-  SCM_PACK (objcode_cells.cells+128),
-  SCM_PACK (objcode_cells.cells+130),
-  SCM_PACK (objcode_cells.cells+132),
-  SCM_PACK (objcode_cells.cells+134),
-  SCM_PACK (objcode_cells.cells+136),
-  SCM_PACK (objcode_cells.cells+138),
-  SCM_PACK (objcode_cells.cells+140),
-  SCM_PACK (objcode_cells.cells+142),
-  SCM_PACK (objcode_cells.cells+144),
-  SCM_PACK (objcode_cells.cells+146),
-  SCM_PACK (objcode_cells.cells+148),
-  SCM_PACK (objcode_cells.cells+150),
-  SCM_PACK (objcode_cells.cells+152),
-  SCM_PACK (objcode_cells.cells+154),
-  SCM_PACK (objcode_cells.cells+156),
-  SCM_PACK (objcode_cells.cells+158),
-  SCM_PACK (objcode_cells.cells+160),
+  A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
+  AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
 
   /* 9 arguments */
-  SCM_PACK (objcode_cells.cells+162),
-  SCM_PACK (objcode_cells.cells+164),
-  SCM_PACK (objcode_cells.cells+166),
-  SCM_PACK (objcode_cells.cells+168),
-  SCM_PACK (objcode_cells.cells+170),
-  SCM_PACK (objcode_cells.cells+172),
-  SCM_PACK (objcode_cells.cells+174),
-  SCM_PACK (objcode_cells.cells+176),
-  SCM_PACK (objcode_cells.cells+178),
-  SCM_PACK (objcode_cells.cells+180),
-  SCM_PACK (objcode_cells.cells+182),
-  SCM_PACK (objcode_cells.cells+184),
-  SCM_PACK (objcode_cells.cells+186),
-  SCM_PACK (objcode_cells.cells+188),
-  SCM_PACK (objcode_cells.cells+190),
-  SCM_PACK (objcode_cells.cells+192),
-  SCM_PACK (objcode_cells.cells+194),
-  SCM_PACK (objcode_cells.cells+196),
-  SCM_PACK (objcode_cells.cells+198),
+  A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), 
AB(1,8), B(9),
+  AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), ABC(1,7), 
BC(8),
 
   /* 10 arguments */
-  SCM_PACK (objcode_cells.cells+200),
-  SCM_PACK (objcode_cells.cells+202),
-  SCM_PACK (objcode_cells.cells+204),
-  SCM_PACK (objcode_cells.cells+206),
-  SCM_PACK (objcode_cells.cells+208),
-  SCM_PACK (objcode_cells.cells+210),
-  SCM_PACK (objcode_cells.cells+212),
-  SCM_PACK (objcode_cells.cells+214),
-  SCM_PACK (objcode_cells.cells+216),
-  SCM_PACK (objcode_cells.cells+218),
-  SCM_PACK (objcode_cells.cells+220),
-  SCM_PACK (objcode_cells.cells+222),
-  SCM_PACK (objcode_cells.cells+224),
-  SCM_PACK (objcode_cells.cells+226),
-  SCM_PACK (objcode_cells.cells+228),
-  SCM_PACK (objcode_cells.cells+230),
-  SCM_PACK (objcode_cells.cells+232),
-  SCM_PACK (objcode_cells.cells+234),
-  SCM_PACK (objcode_cells.cells+236),
-  SCM_PACK (objcode_cells.cells+238),
-  SCM_PACK (objcode_cells.cells+240)
+  A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), 
AB(2,8), AB(1,9), B(10),
+  AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), ABC(2,7), 
ABC(1,8), BC(9),
 };
 
+#undef A
+#undef B
+#undef C
+#undef AB
+#undef AC
+#undef BC
+#undef ABC
+
 /* (nargs * nargs) + nopt + rest * (nargs + 1) */
-#define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest)                     \
-  scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
-                               + nopt + rest * (nreq + nopt + rest + 1)]
+#define SUBR_STUB_CODE(nreq,nopt,rest)                                \
+  &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest)        \
+                   + nopt + rest * (nreq + nopt + rest + 1)) * 4]
 
-SCM
-scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt,
-                             unsigned int rest)
+static const scm_t_uint32*
+get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
 {
   if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
     scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
       
-  return SCM_SUBR_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
+  return SUBR_STUB_CODE (nreq, nopt, rest);
 }
 
 static SCM
-create_gsubr (int define, const char *name,
-             unsigned int nreq, unsigned int nopt, unsigned int rest,
-             SCM (*fcn) (), SCM *generic_loc)
+create_subr (int define, const char *name,
+             unsigned int nreq, unsigned int nopt, unsigned int rest,
+             SCM (*fcn) (), SCM *generic_loc)
 {
-  SCM ret;
-  SCM sname;
-  SCM table;
+  SCM ret, sname;
   scm_t_bits flags;
+  scm_t_bits nfree = generic_loc ? 3 : 2;
 
-  /* make objtable */
   sname = scm_from_utf8_symbol (name);
-  table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
-  SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
-  SCM_SIMPLE_VECTOR_SET (table, 1, sname);
-  if (generic_loc)
-    SCM_SIMPLE_VECTOR_SET (table, 2,
-                           scm_from_pointer (generic_loc, NULL));
 
-  /* make program */
-  ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
-                          table, SCM_BOOL_F);
-
-  /* set flags */
+  ret = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
   flags = SCM_F_PROGRAM_IS_PRIMITIVE;
   flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);
+  SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest));
+  SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
+  SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
+  if (generic_loc)
+    SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 2,
+                                       scm_from_pointer (generic_loc, NULL));
 
-  /* define, if needed */
   if (define)
     scm_define (sname, ret);
 
-  /* et voila. */
   return ret;
 }
 
+/* Given an RTL primitive, determine its minimum arity.  This is
+   possible because each RTL primitive is 4 32-bit words long, and they
+   are laid out contiguously in an ordered pattern.  */
+int
+scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
+{
+  const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (prim);
+  unsigned idx, nargs, base, next;
+
+  if (code < subr_stub_code)
+    return 0;
+  if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
+    return 0;
+
+  idx = (code - subr_stub_code) / 4;
+
+  nargs = -1;
+  next = 0;
+  do
+    {
+      base = next;
+      nargs++;
+      next = (nargs + 1) * (nargs + 1);
+    }
+  while (idx >= next);
+
+  *rest = (next - idx) < (idx - base);
+  *req = *rest ? (next - 1) - idx : (base + nargs) - idx;
+  *opt = *rest ? idx - (next - nargs) : idx - base;
+
+  return 1;
+}
+
+int
+scm_i_primitive_call_ip (SCM subr)
+{
+  const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (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;
+}
+
 SCM
 scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 {
-  return create_gsubr (0, name, req, opt, rst, fcn, NULL);
+  return create_subr (0, name, req, opt, rst, fcn, NULL);
 }
 
 SCM
 scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 {
-  return create_gsubr (1, name, req, opt, rst, fcn, NULL);
+  return create_subr (1, name, req, opt, rst, fcn, NULL);
 }
 
 SCM
@@ -836,7 +317,7 @@ scm_c_make_gsubr_with_generic (const char *name,
                               SCM (*fcn)(),
                               SCM *gf)
 {
-  return create_gsubr (0, name, req, opt, rst, fcn, gf);
+  return create_subr (0, name, req, opt, rst, fcn, gf);
 }
 
 SCM
@@ -847,38 +328,12 @@ scm_c_define_gsubr_with_generic (const char *name,
                                 SCM (*fcn)(),
                                 SCM *gf)
 {
-  return create_gsubr (1, name, req, opt, rst, fcn, gf);
+  return create_subr (1, name, req, opt, rst, fcn, gf);
 }
 
-
-#ifdef GSUBR_TEST
-/* A silly example, taking 2 required args, 1 optional, and
-   a scm_list of rest args
-   */
-SCM
-gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
-{
-  scm_puts_unlocked ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
-  scm_display(req1, scm_cur_outp);
-  scm_puts_unlocked ("\n req2: ", scm_cur_outp);
-  scm_display(req2, scm_cur_outp);
-  scm_puts_unlocked ("\n opt: ", scm_cur_outp);
-  scm_display(opt, scm_cur_outp);
-  scm_puts_unlocked ("\n rest: ", scm_cur_outp);
-  scm_display(rst, scm_cur_outp);
-  scm_newline(scm_cur_outp);
-  return SCM_UNSPECIFIED;
-}
-#endif
-
-
 void
 scm_init_gsubr()
 {
-#ifdef GSUBR_TEST
-  scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
-#endif
-
 #include "libguile/gsubr.x"
 }
 
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 5adffa4..6bdfe6b 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -4,7 +4,7 @@
 #define SCM_GSUBR_H
 
 /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2006, 2008, 2009,
- *   2010, 2011 Free Software Foundation, Inc.
+ *   2010, 2011, 2013 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -30,36 +30,33 @@
 
 
 
-SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
-                                         unsigned int nopt,
-                                         unsigned int rest);
-
-
 /* Subrs 
  */
 
 /* Max number of args to the C procedure backing a gsubr */
 #define SCM_GSUBR_MAX 10
 
-#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
+#define SCM_PRIMITIVE_P(x) (SCM_RTL_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE 
(x))
 
-#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && 
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
+#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_RTL_PROGRAM_P (x) && 
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
 
 #define SCM_SUBRF(x)                                                   \
-  ((SCM (*) (void))                                                    \
-   SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0)))
+  ((SCM (*) (void))                                                     \
+   SCM_POINTER_VALUE (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 0)))
 
-#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
+#define SCM_SUBR_NAME(x) (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 1))
 
 #define SCM_SUBR_GENERIC(x)                                            \
-  ((SCM *)                                                             \
-   SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))
+  ((SCM *) SCM_POINTER_VALUE (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 2)))
 
 #define SCM_SET_SUBR_GENERIC(x, g) \
   (*SCM_SUBR_GENERIC (x) = (g))
 
 
 
+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_API SCM scm_c_make_gsubr (const char *name,
                              int req, int opt, int rst, scm_t_subr fcn);
 SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
diff --git a/libguile/programs.c b/libguile/programs.c
index 5039d2a..c10dede 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -116,6 +116,9 @@ scm_i_rtl_program_name (SCM program)
 {
   static SCM rtl_program_name = SCM_BOOL_F;
 
+  if (SCM_PRIMITIVE_P (program))
+    return SCM_SUBR_NAME (program);
+
   if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
     rtl_program_name =
         scm_c_private_variable ("system vm program", "rtl-program-name");
@@ -128,6 +131,9 @@ scm_i_rtl_program_documentation (SCM program)
 {
   static SCM rtl_program_documentation = SCM_BOOL_F;
 
+  if (SCM_PRIMITIVE_P (program))
+    return SCM_BOOL_F;
+
   if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
     rtl_program_documentation =
       scm_c_private_variable ("system vm program",
@@ -141,6 +147,14 @@ scm_i_rtl_program_properties (SCM program)
 {
   static SCM rtl_program_properties = SCM_BOOL_F;
 
+  if (SCM_PRIMITIVE_P (program))
+    {
+      SCM name = scm_i_rtl_program_name (program);
+      if (scm_is_false (name))
+        return SCM_EOL;
+      return scm_acons (scm_sym_name, name, SCM_EOL);
+    }
+
   if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
     rtl_program_properties =
       scm_c_private_variable ("system vm program", "rtl-program-properties");
@@ -219,6 +233,26 @@ SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0,
+           (SCM obj),
+           "")
+#define FUNC_NAME s_scm_primitive_p
+{
+  return scm_from_bool (SCM_PRIMITIVE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
+           (SCM prim),
+           "")
+#define FUNC_NAME s_scm_primitive_p
+{
+  SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
+
+  return scm_from_int (scm_i_primitive_call_ip (prim));
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
            (SCM program),
            "")
@@ -487,6 +521,9 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int 
*opt, int *rest)
   static SCM rtl_program_minimum_arity = SCM_BOOL_F;
   SCM l;
 
+  if (SCM_PRIMITIVE_P (program))
+    return scm_i_primitive_arity (program, req, opt, rest);
+
   if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
     rtl_program_minimum_arity =
         scm_c_private_variable ("system vm program",
diff --git a/libguile/programs.h b/libguile/programs.h
index 275570c..1ecc35d 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -44,6 +44,9 @@ SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM 
byte_offset, SCM free
 SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
 SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
 
+SCM_INTERNAL SCM scm_primitive_p (SCM obj);
+SCM_INTERNAL SCM scm_primitive_call_ip (SCM prim);
+
 SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
 SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
 SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 3931570..7843ac8 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -4,7 +4,7 @@
 #define SCM_SNARF_H
 
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- *   2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+ *   2004, 2006, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -96,48 +96,9 @@ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
 )\
 SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
 
-#ifdef SCM_SUPPORT_STATIC_ALLOCATION
-
-/* Static subr allocation.  */
-/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
-#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
-SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME);                    \
-SCM_SNARF_HERE(                                                                
\
-  static const char scm_i_paste (s_, FNAME) [] = PRIMNAME;             \
-  SCM_API SCM FNAME ARGLIST;                                           \
-  SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign),           \
-                         (scm_t_bits) &FNAME); /* the subr */           \
-  SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable),         \
-                           /* FIXME: directly be the foreign */         \
-                           SCM_BOOL_F);                                 \
-  /* FIXME: be immutable. grr */                                        \
-  SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr),                     \
-                      SCM_BOOL_F,                                       \
-                      SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)),  \
-                      SCM_BOOL_F);                                      \
-  SCM FNAME ARGLIST                                                    \
-)                                                                      \
-SCM_SNARF_INIT(                                                        \
-  /* Initialize the foreign.  */                                        \
-  scm_i_paste (FNAME, __raw_objtable)[1] = scm_i_paste (FNAME, 
__subr_foreign); \
-  /* Initialize the procedure name (an interned symbol).  */           \
-  scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __name); \
-  /* Initialize the objcode trampoline.  */                             \
-  SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1,                  \
-                       scm_subr_objcode_trampoline (REQ, OPT, VAR));    \
-                                                                       \
-  /* Define the subr.  */                                              \
-  scm_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \
-)                                                                      \
-SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
-
-#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
-
 /* Always use the generic subr case.  */
 #define SCM_DEFINE SCM_DEFINE_GSUBR
 
-#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
-
 
 #define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, 
DOCSTRING) \
 SCM_SNARF_HERE(\
diff --git a/module/statprof.scm b/module/statprof.scm
index c4483a2..36c53a5 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -426,7 +426,7 @@ none is available."
   (if (positive? profile-level)
       (error "Can't call statprof-fold-called while profiler is running."))
 
-  (hashq-ref procedure-data proc))
+  (get-call-data proc))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Stats
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index f7adb20..8eb4237 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -253,6 +253,14 @@ section of the ELF image.  Returns an ELF symbol, or 
@code{#f}."
 (define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
 (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)))
+
+(define (arity-high-pc arity)
+  (arity-high-pc* (elf-bytes (debug-context-elf (arity-context arity)))
+                  (arity-header-offset arity)))
+
 (define (arity-nreq arity)
   (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
                (arity-header-offset arity)))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 86db411..4466504 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -198,7 +198,8 @@
 ;; returns list of list of bindings
 ;; (list-ref ret N) == bindings bound to the Nth local slot
 (define (program-bindings-by-index prog)
-  (cond ((program-bindings prog) => collapse-locals)
+  (cond ((rtl-program? prog) '())
+        ((program-bindings prog) => collapse-locals)
         (else '())))
 
 (define (program-bindings-for-ip prog ip)
@@ -291,14 +292,29 @@
 ;; the name "program-arguments" is taken by features.c...
 (define* (program-arguments-alist prog #:optional ip)
   "Returns the signature of the given procedure in the form of an association 
list."
-  (if (rtl-program? prog)
+  (cond
+   ((primitive? prog)
+    (match (procedure-minimum-arity prog)
+      (#f #f)
+      ((nreq nopt rest?)
+       (let ((start (primitive-call-ip prog)))
+         ;; Assume that there is only one IP for the call.
+         (and (or (not ip) (= start ip))
+              (arity->arguments-alist
+               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 #t
+                (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)) '()))
-      (let ((arity (program-arity prog ip)))
-        (and arity
-             (arity->arguments-alist prog arity)))))
+              (or (find-program-arities (rtl-program-code prog)) '()))))
+   (else
+    (let ((arity (program-arity prog ip)))
+      (and arity
+           (arity->arguments-alist prog arity))))))
 
 (define* (program-lambda-list prog #:optional ip)
   "Returns the signature of the given procedure in the form of an argument 
list."
@@ -325,6 +341,14 @@
 
 (define (program-arguments-alists prog)
   (cond
+   ((primitive? prog)
+    (match (procedure-minimum-arity prog)
+      (#f '())
+      ((nreq nopt rest?)
+       (list
+        (arity->arguments-alist
+         prog
+         (list 0 0 nreq nopt rest? '(#f . ())))))))
    ((rtl-program? prog)
     (map arity-arguments-alist
          (or (find-program-arities (rtl-program-code prog)) '())))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 24afe2d..a0221b8 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,5 @@
 ;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free 
Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free 
Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -349,7 +349,9 @@
 (define tag (make-prompt-tag "foo"))
 
 (with-test-prefix "stacks"
-  (pass-if "stack involving a primitive"
+  ;; 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"
     ;; 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]