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. release_1-9-6-106-g75


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-6-106-g75c3ed2
Date: Sat, 09 Jan 2010 13:20:59 +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=75c3ed282029f4d2a80adf75f52ec1b9b34edcb7

The branch, master has been updated
       via  75c3ed282029f4d2a80adf75f52ec1b9b34edcb7 (commit)
       via  9174596d5bfc456d06f4cf74a7a67e9b2b09aac3 (commit)
      from  a589525d4e1d0e4ce385a01820a7fa6fa9a5030e (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 75c3ed282029f4d2a80adf75f52ec1b9b34edcb7
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 9 14:12:47 2010 +0100

    smobs are applied with vm trampoline procedures
    
    * libguile/smob.c: Instead of having special evaluator support for
      applying smobs, we use the same strategy that gsubr uses, that smob
      application should happen via a trampoline VM procedure, which uses a
      special opcode (smob-apply). So statically allocate all of the desired
      trampoline procedures here.
      (scm_i_smob_apply_trampoline): Unfortunately there's no real place to
      put the trampoline, so instead use a weak-key hash. It's nasty, but I
      think the benefits of speeding up procedure calls in the general case
      are worth it.
    
    * libguile/smob.h (scm_smob_descriptor): Remove fields apply_0, apply_1,
      apply_2, and apply_3; these were never public. Also remove the
      gsubr_type field. Instead cache the trampoline objcode here.
      (SCM_SMOB_APPLY_0, SCM_SMOB_APPLY_1, SCM_SMOB_APPLY_2,
      SCM_SMOB_APPLY_3): Just go through scm_call_0, etc here.
    
    * libguile/vm-i-system.c (call, tail-call, mv-call): Simplify. All
      procedure calls are VM calls now.
      (smob-call): New instruction, used in smob trampoline procedures.
    
    * libguile/vm.c (apply_foreign): Remove. Yay!
    
    * libguile/procprop.c (scm_i_procedure_arity): Refactor a bit for the
      smob changes.

commit 9174596d5bfc456d06f4cf74a7a67e9b2b09aac3
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 9 13:08:06 2010 +0100

    re-add SCM_GSUBR_MAX
    
    * libguile/gsubr.h (SCM_GSUBR_MAX): Restore this define, which specifies
      the max number of args to a gsubr.
    
    * libguile/smob.c: Remove local SCM_GSUBR_MAX define.

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

Summary of changes:
 libguile/gsubr.h       |    3 +
 libguile/procprop.c    |   32 ++--
 libguile/smob.c        |  535 +++++++++++++++++++++++-------------------------
 libguile/smob.h        |   16 +-
 libguile/vm-i-system.c |  259 ++++++++++-------------
 libguile/vm.c          |   33 ---
 6 files changed, 400 insertions(+), 478 deletions(-)

diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index be83a97..a4dc560 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -37,6 +37,9 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
 /* 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_GENERIC_P(x) (SCM_PROGRAM_P (x) && 
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
 
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 641defc..b3c6c86 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -48,23 +48,27 @@ static scm_i_pthread_mutex_t props_lock = 
SCM_I_PTHREAD_MUTEX_INITIALIZER;
 int
 scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
 {
-  if (SCM_IMP (proc))
-    return 0;
- loop:
-  switch (SCM_TYP7 (proc))
+  while (!SCM_PROGRAM_P (proc))
     {
-    case scm_tc7_program:
-      return scm_i_program_arity (proc, req, opt, rest);
-    case scm_tc7_smob:
-      return scm_i_smob_arity (proc, req, opt, rest);
-    case scm_tcs_struct:
-      if (!SCM_STRUCT_APPLICABLE_P (proc))
+      if (SCM_IMP (proc))
         return 0;
-      proc = SCM_STRUCT_PROCEDURE (proc);
-      goto loop;
-    default:
-      return 0;
+      switch (SCM_TYP7 (proc))
+        {
+        case scm_tc7_smob:
+          if (!SCM_SMOB_APPLICABLE_P (proc))
+            return 0;
+          proc = scm_i_smob_apply_trampoline (proc);
+          break;
+        case scm_tcs_struct:
+          if (!SCM_STRUCT_APPLICABLE_P (proc))
+            return 0;
+          proc = SCM_STRUCT_PROCEDURE (proc);
+          break;
+        default:
+          return 0;
+        }
     }
+  return scm_i_program_arity (proc, req, opt, rest);
 }
 
 /* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
diff --git a/libguile/smob.c b/libguile/smob.c
index 037164b..171db8d 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -17,13 +17,6 @@
  */
 
 
-#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
-#define SCM_GSUBR_MAX    33
-#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
-#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
-#define SCM_GSUBR_REST(x) ((long)(x)>>8)
-
-
 
 #ifdef HAVE_CONFIG_H
 #  include <config.h>
@@ -36,7 +29,9 @@
 
 #include "libguile/async.h"
 #include "libguile/goops.h"
-#include "libguile/ports.h"
+#include "libguile/instructions.h"
+#include "libguile/objcodes.h"
+#include "libguile/programs.h"
 
 #ifdef HAVE_MALLOC_H
 #include <malloc.h>
@@ -124,159 +119,237 @@ scm_smob_print (SCM exp, SCM port, scm_print_state 
*pstate SCM_UNUSED)
   return 1;
 }
 
+
 /* {Apply}
  */
 
-#define SCM_SMOB_APPLY0(SMOB) \
-  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
-#define SCM_SMOB_APPLY1(SMOB, A1) \
-  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
-#define SCM_SMOB_APPLY2(SMOB, A1, A2) \
-  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
-#define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
-  SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
-
-static SCM
-scm_smob_apply_0_010 (SCM smob)
-{
-  return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_0_020 (SCM smob)
-{
-  return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_0_030 (SCM smob)
-{
-  return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_0_001 (SCM smob)
-{
-  return SCM_SMOB_APPLY1 (smob, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_0_011 (SCM smob)
-{
-  return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_0_021 (SCM smob)
-{
-  return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_0_error (SCM smob)
-{
-  scm_wrong_num_args (smob);
-}
-
-static SCM
-scm_smob_apply_1_020 (SCM smob, SCM a1)
-{
-  return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_1_030 (SCM smob, SCM a1)
-{
-  return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_1_001 (SCM smob, SCM a1)
-{
-  return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
-}
-
-static SCM
-scm_smob_apply_1_011 (SCM smob, SCM a1)
-{
-  return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_1_021 (SCM smob, SCM a1)
-{
-  return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
-{
-  scm_wrong_num_args (smob);
-}
-
-static SCM
-scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
-{
-  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
-{
-  return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
-}
-
-static SCM
-scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
-{
-  return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
-}
-
-static SCM
-scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
-{
-  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
-{
-  scm_wrong_num_args (smob);
-}
-
-static SCM
-scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
-  if (!scm_is_null (SCM_CDR (rst)))
-    scm_wrong_num_args (smob);
-  return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
-}
-
-static SCM
-scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
-  return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
-}
-
-static SCM
-scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
-  return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
-}
+#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
 
-static SCM
-scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
-  return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
-}
+/* This code is the same as in gsubr.c, except we use smob_call instead of
+   struct_call. */
+
+/* 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_smob_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)
+
+#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 smob 
pointer */ \
+  /* 8 */ scm_op_smob_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)
+
+#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 smob 
pointer */ \
+  /* 5 */ scm_op_smob_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)
+
+#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 smob 
pointer */ \
+  /* 11 */ scm_op_smob_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)
+
+#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 smob 
pointer */ \
+  /* 8 */ scm_op_smob_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)
+
+#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 smob 
pointer */ \
+  /* 8 */ scm_op_smob_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)
+
+#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 smob 
pointer */ \
+  /* 11 */ scm_op_smob_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 */
+
+static const struct
+{
+  scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way 
*/
+  const scm_t_uint8 bytes[16 * (sizeof (struct scm_objcode) + 16
+                                + sizeof (struct scm_objcode) + 32)];
+} raw_bytecode = {
+  0,
+  {
+    /* Use the elisp macros from gsubr.c */
+    /* C-u 3 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)
+  }
+};
+
+#undef A
+#undef B
+#undef C
+#undef AB
+#undef AC
+#undef BC
+#undef ABC
+#undef OBJCODE_HEADER
+#undef META_HEADER
+#undef META
+
+#define STATIC_OBJCODE_TAG                                      \
+  SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+static const struct
+{
+  scm_t_uint64 dummy; /* alignment */
+  scm_t_cell cells[16 * 2]; /* 4*4 double cells */
+} objcode_cells = {
+  0,
+  /* C-u 3 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) }
+  }
+};
+  
+static const SCM scm_smob_objcode_trampolines[16] = {
+  /* C-u 3 M-x generate-objcodes RET */
+  /* 0 arguments */
+  SCM_PACK (objcode_cells.cells+0),
+
+  /* 1 arguments */
+  SCM_PACK (objcode_cells.cells+2),
+  SCM_PACK (objcode_cells.cells+4),
+  SCM_PACK (objcode_cells.cells+6),
+
+  /* 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),
+
+  /* 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)
+};
+
+/* (nargs * nargs) + nopt + rest * (nargs + 1) */
+#define SCM_SMOB_OBJCODE_TRAMPOLINE(nreq,nopt,rest)                     \
+  scm_smob_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
+                               + nopt + rest * (nreq + nopt + rest + 1)]
 
 static SCM
-scm_smob_apply_3_error (SCM smob,
-                       SCM a1 SCM_UNUSED,
-                       SCM a2 SCM_UNUSED,
-                       SCM rst SCM_UNUSED)
+scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
+                             unsigned int rest)
 {
-  scm_wrong_num_args (smob);
+  if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
+    scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));
+      
+  return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
 }
 
 
@@ -336,113 +409,40 @@ void
 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
                    unsigned int req, unsigned int opt, unsigned int rst)
 {
-  SCM (*apply_0) (SCM);
-  SCM (*apply_1) (SCM, SCM);
-  SCM (*apply_2) (SCM, SCM, SCM);
-  SCM (*apply_3) (SCM, SCM, SCM, SCM);
-  int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
-
-  if (rst > 1 || req + opt + rst > 3)
-    {
-      puts ("Unsupported smob application type");
-      abort ();
-    }
-
-  switch (type)
-    {
-    case SCM_GSUBR_MAKTYPE (0, 0, 0):
-      apply_0 = apply; break;
-    case SCM_GSUBR_MAKTYPE (0, 1, 0):
-      apply_0 = scm_smob_apply_0_010; break;
-    case SCM_GSUBR_MAKTYPE (0, 2, 0):
-      apply_0 = scm_smob_apply_0_020; break;
-    case SCM_GSUBR_MAKTYPE (0, 3, 0):
-      apply_0 = scm_smob_apply_0_030; break;
-    case SCM_GSUBR_MAKTYPE (0, 0, 1):
-      apply_0 = scm_smob_apply_0_001; break;
-    case SCM_GSUBR_MAKTYPE (0, 1, 1):
-      apply_0 = scm_smob_apply_0_011; break;
-    case SCM_GSUBR_MAKTYPE (0, 2, 1):
-      apply_0 = scm_smob_apply_0_021; break;
-    default:
-      apply_0 = scm_smob_apply_0_error; break;
-    }
+  scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
+  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
+    = scm_smob_objcode_trampoline (req, opt, rst);
 
-  switch (type)
-    {
-    case SCM_GSUBR_MAKTYPE (1, 0, 0):
-    case SCM_GSUBR_MAKTYPE (0, 1, 0):
-      apply_1 = apply; break;
-    case SCM_GSUBR_MAKTYPE (1, 1, 0):
-    case SCM_GSUBR_MAKTYPE (0, 2, 0):
-      apply_1 = scm_smob_apply_1_020; break;
-    case SCM_GSUBR_MAKTYPE (1, 2, 0):
-    case SCM_GSUBR_MAKTYPE (0, 3, 0):
-      apply_1 = scm_smob_apply_1_030; break;
-    case SCM_GSUBR_MAKTYPE (0, 0, 1):
-      apply_1 = scm_smob_apply_1_001; break;
-    case SCM_GSUBR_MAKTYPE (1, 0, 1):
-    case SCM_GSUBR_MAKTYPE (0, 1, 1):
-      apply_1 = scm_smob_apply_1_011; break;
-    case SCM_GSUBR_MAKTYPE (1, 1, 1):
-    case SCM_GSUBR_MAKTYPE (0, 2, 1):
-      apply_1 = scm_smob_apply_1_021; break;
-    default:
-      apply_1 = scm_smob_apply_1_error; break;
-    }
+  if (SCM_UNPACK (scm_smob_class[0]) != 0)
+    scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
+}
 
-  switch (type)
-    {
-    case SCM_GSUBR_MAKTYPE (2, 0, 0):
-    case SCM_GSUBR_MAKTYPE (1, 1, 0):
-    case SCM_GSUBR_MAKTYPE (0, 2, 0):
-      apply_2 = apply; break;
-    case SCM_GSUBR_MAKTYPE (2, 1, 0):
-    case SCM_GSUBR_MAKTYPE (1, 2, 0):
-    case SCM_GSUBR_MAKTYPE (0, 3, 0):
-      apply_2 = scm_smob_apply_2_030; break;
-    case SCM_GSUBR_MAKTYPE (0, 0, 1):
-      apply_2 = scm_smob_apply_2_001; break;
-    case SCM_GSUBR_MAKTYPE (1, 0, 1):
-    case SCM_GSUBR_MAKTYPE (0, 1, 1):
-      apply_2 = scm_smob_apply_2_011; break;
-    case SCM_GSUBR_MAKTYPE (2, 0, 1):
-    case SCM_GSUBR_MAKTYPE (1, 1, 1):
-    case SCM_GSUBR_MAKTYPE (0, 2, 1):
-      apply_2 = scm_smob_apply_2_021; break;
-    default:
-      apply_2 = scm_smob_apply_2_error; break;
-    }
+static SCM tramp_weak_map = SCM_BOOL_F;
+SCM
+scm_i_smob_apply_trampoline (SCM smob)
+{
+  /* could use hashq-create-handle!, but i don't know what to do if it returns 
a
+     weak pair */
+  SCM tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
 
-  switch (type)
+  if (scm_is_true (tramp))
+    return tramp;
+  else
     {
-    case SCM_GSUBR_MAKTYPE (3, 0, 0):
-    case SCM_GSUBR_MAKTYPE (2, 1, 0):
-    case SCM_GSUBR_MAKTYPE (1, 2, 0):
-    case SCM_GSUBR_MAKTYPE (0, 3, 0):
-      apply_3 = scm_smob_apply_3_030; break;
-    case SCM_GSUBR_MAKTYPE (0, 0, 1):
-      apply_3 = scm_smob_apply_3_001; break;
-    case SCM_GSUBR_MAKTYPE (1, 0, 1):
-    case SCM_GSUBR_MAKTYPE (0, 1, 1):
-      apply_3 = scm_smob_apply_3_011; break;
-    case SCM_GSUBR_MAKTYPE (2, 0, 1):
-    case SCM_GSUBR_MAKTYPE (1, 1, 1):
-    case SCM_GSUBR_MAKTYPE (0, 2, 1):
-      apply_3 = scm_smob_apply_3_021; break;
-    default:
-      apply_3 = scm_smob_apply_3_error; break;
+      const char *name;
+      SCM objtable;
+
+      name = SCM_SMOBNAME (SCM_SMOBNUM (smob));
+      if (!name)
+        name = "smob-apply";
+      objtable = scm_c_make_vector (2, SCM_UNDEFINED);
+      SCM_SIMPLE_VECTOR_SET (objtable, 0, smob);
+      SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
+      tramp = scm_make_program (SCM_SMOB_DESCRIPTOR 
(smob).apply_trampoline_objcode,
+                                objtable, SCM_BOOL_F);
+      scm_hashq_set_x (tramp_weak_map, smob, tramp);
+      return tramp;
     }
-
-  scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
-  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
-  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
-  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
-  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
-  scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
-
-  if (SCM_UNPACK (scm_smob_class[0]) != 0)
-    scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 }
 
 SCM
@@ -593,21 +593,6 @@ scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
     free_smob (smob);
 }
 
-int
-scm_i_smob_arity (SCM proc, int *req, int *opt, int *rest)
-{
-  if (SCM_SMOB_APPLICABLE_P (proc))
-    {
-      int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
-      *req = SCM_GSUBR_REQ (type);
-      *opt = SCM_GSUBR_OPT (type);
-      *rest = SCM_GSUBR_REST (type);
-      return 1;
-    }
-  else
-    return 0;
-}
-
 
 void
 scm_smob_prehistory ()
@@ -631,12 +616,10 @@ scm_smob_prehistory ()
       scm_smobs[i].print      = scm_smob_print;
       scm_smobs[i].equalp     = 0;
       scm_smobs[i].apply      = 0;
-      scm_smobs[i].apply_0    = 0;
-      scm_smobs[i].apply_1    = 0;
-      scm_smobs[i].apply_2    = 0;
-      scm_smobs[i].apply_3    = 0;
-      scm_smobs[i].gsubr_type = 0;
+      scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
     }
+
+  tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 }
 
 /*
diff --git a/libguile/smob.h b/libguile/smob.h
index a79c39c..07deebd 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -41,11 +41,7 @@ typedef struct scm_smob_descriptor
   int (*print) (SCM exp, SCM port, scm_print_state *pstate);
   SCM (*equalp) (SCM, SCM);
   SCM (*apply) ();
-  SCM (*apply_0) (SCM);
-  SCM (*apply_1) (SCM, SCM);
-  SCM (*apply_2) (SCM, SCM, SCM);
-  SCM (*apply_3) (SCM, SCM, SCM, SCM);
-  int gsubr_type; /* Used in procprop.c */
+  SCM apply_trampoline_objcode;
 } scm_smob_descriptor;
 
 
@@ -170,10 +166,10 @@ while (0)
 #define SCM_SMOB_PREDICATE(tag, obj)   SCM_TYP16_PREDICATE (tag, obj)
 #define SCM_SMOB_DESCRIPTOR(x)         (scm_smobs[SCM_SMOBNUM (x)])
 #define SCM_SMOB_APPLICABLE_P(x)       (SCM_SMOB_DESCRIPTOR (x).apply)
-#define SCM_SMOB_APPLY_0(x)            (SCM_SMOB_DESCRIPTOR (x).apply_0 (x))
-#define SCM_SMOB_APPLY_1(x, a1)                (SCM_SMOB_DESCRIPTOR 
(x).apply_1 (x, (a1)))
-#define SCM_SMOB_APPLY_2(x, a1, a2)    (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, 
(a1), (a2)))
-#define SCM_SMOB_APPLY_3(x, a1, a2, rst)       (SCM_SMOB_DESCRIPTOR 
(x).apply_3 (x, (a1), (a2), (rst)))
+#define SCM_SMOB_APPLY_0(x)            (scm_call_0 (x))
+#define SCM_SMOB_APPLY_1(x, a1)                (scm_call_1 (x, a1))
+#define SCM_SMOB_APPLY_2(x, a1, a2)    (scm_call_2 (x, a1, a2))
+#define SCM_SMOB_APPLY_3(x, a1, a2, rst) (scm_call_3 (x, a1, a2, a3))
 
 /* Maximum number of SMOB types.  */
 #define SCM_I_MAX_SMOB_TYPE_COUNT  256
@@ -217,7 +213,7 @@ SCM_API void scm_assert_smob_type (scm_t_bits tag, SCM val);
 
 SCM_API SCM scm_make_smob (scm_t_bits tc);
 
-SCM_INTERNAL int scm_i_smob_arity (SCM proc, int *req, int *opt, int *rest);
+SCM_INTERNAL SCM scm_i_smob_apply_trampoline (SCM smob);
 
 SCM_API void scm_smob_prehistory (void);
 
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 546c9e0..dab268f 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -744,83 +744,70 @@ VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0, 
3)
 
 VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
 {
-  SCM x;
   nargs = FETCH ();
 
  vm_call:
-  x = sp[-nargs];
+  program = sp[-nargs];
 
   VM_HANDLE_INTERRUPTS;
 
-  /*
-   * Subprogram call
-   */
-  if (SCM_PROGRAM_P (x))
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
     {
-      program = x;
-      CACHE_PROGRAM ();
-      fp = sp - nargs + 1;
-      ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
-      ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
-      SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
-      SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
-      ip = SCM_C_OBJCODE_BASE (bp);
-      ENTER_HOOK ();
-      APPLY_HOOK ();
-      NEXT;
-    }
-  if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
-    {
-      sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
-      goto vm_call;
-    }
-  /*
-   * Other interpreted or compiled call
-   */
-  if (!scm_is_false (scm_procedure_p (x)))
-    {
-      SCM ret;
-      /* At this point, the stack contains the frame, the procedure and each 
one
-        of its arguments. */
-      SYNC_REGISTER ();
-      ret = apply_foreign (sp[-nargs],
-                           sp - nargs + 1,
-                           nargs,
-                           vp->stack_limit - sp + 1);
-      NULLSTACK_FOR_NONLOCAL_EXIT ();
-      DROPN (nargs + 1); /* drop args and procedure */
-      DROP_FRAME ();
-      
-      if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
         {
-          /* truncate values */
-          ret = scm_struct_ref (ret, SCM_INUM0);
-          if (scm_is_null (ret))
-            goto vm_error_not_enough_values;
-          PUSH (SCM_CAR (ret));
+          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
+          goto vm_call;
+        }
+      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+               && SCM_SMOB_APPLICABLE_P (program))
+        {
+          SYNC_REGISTER ();
+          sp[-nargs] = scm_i_smob_apply_trampoline (program);
+          goto vm_call;
         }
       else
-        PUSH (ret);
-      NEXT;
+        goto vm_error_wrong_type_apply;
     }
 
-  program = x;
-  goto vm_error_wrong_type_apply;
+  CACHE_PROGRAM ();
+  fp = sp - nargs + 1;
+  ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+  ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+  SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+  SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
+  ip = SCM_C_OBJCODE_BASE (bp);
+  ENTER_HOOK ();
+  APPLY_HOOK ();
+  NEXT;
 }
 
 VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
 {
-  register SCM x;
   nargs = FETCH ();
+
  vm_tail_call:
-  x = sp[-nargs];
+  program = sp[-nargs];
 
   VM_HANDLE_INTERRUPTS;
 
-  /*
-   * Tail call
-   */
-  if (SCM_PROGRAM_P (x))
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+    {
+      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
+        {
+          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
+          goto vm_tail_call;
+        }
+      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+               && SCM_SMOB_APPLICABLE_P (program))
+        {
+          SYNC_REGISTER ();
+          sp[-nargs] = scm_i_smob_apply_trampoline (program);
+          goto vm_tail_call;
+        }
+      else
+        goto vm_error_wrong_type_apply;
+    }
+  else
     {
       int i;
 #ifdef VM_ENABLE_STACK_NULLING
@@ -831,7 +818,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
       EXIT_HOOK ();
 
       /* switch programs */
-      program = x;
       CACHE_PROGRAM ();
       /* shuffle down the program and the arguments */
       for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
@@ -847,43 +833,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 
1)
       APPLY_HOOK ();
       NEXT;
     }
-  if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
-    {
-      sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
-      goto vm_tail_call;
-    }
-  /*
-   * Other interpreted or compiled call
-   */
-  if (!scm_is_false (scm_procedure_p (x)))
-    {
-      SCM ret;
-      SYNC_REGISTER ();
-      ret = apply_foreign (sp[-nargs],
-                           sp - nargs + 1,
-                           nargs,
-                           vp->stack_limit - sp + 1);
-      NULLSTACK_FOR_NONLOCAL_EXIT ();
-      DROPN (nargs + 1); /* drop args and procedure */
-      
-      if (SCM_UNLIKELY (SCM_VALUESP (ret)))
-        {
-          /* multiple values returned to continuation */
-          ret = scm_struct_ref (ret, SCM_INUM0);
-          nvalues = scm_ilength (ret);
-          PUSH_LIST (ret, scm_is_null);
-          goto vm_return_values;
-        }
-      else
-        {
-          PUSH (ret);
-          goto vm_return;
-        }
-    }
-
-  program = x;
-
-  goto vm_error_wrong_type_apply;
 }
 
 VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1)
@@ -955,6 +904,54 @@ VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, 
-1)
     }
 }
 
+VM_DEFINE_INSTRUCTION (81, smob_call, "smob-call", 1, -1, -1)
+{
+  SCM smob, ret;
+  SCM (*subr)();
+  nargs = FETCH ();
+  POP (smob);
+
+  subr = SCM_SMOB_DESCRIPTOR (smob).apply;
+
+  VM_HANDLE_INTERRUPTS;
+  SYNC_REGISTER ();
+
+  switch (nargs)
+    {
+    case 0:
+      ret = subr (smob);
+      break;
+    case 1:
+      ret = subr (smob, sp[0]);
+      break;
+    case 2:
+      ret = subr (smob, sp[-1], sp[0]);
+      break;
+    case 3:
+      ret = subr (smob, sp[-2], sp[-1], sp[0]);
+      break;
+    default:
+      abort ();
+    }
+  
+  NULLSTACK_FOR_NONLOCAL_EXIT ();
+  DROPN (nargs + 1); /* drop args and procedure */
+      
+  if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+    {
+      /* multiple values returned to continuation */
+      ret = scm_struct_ref (ret, SCM_INUM0);
+      nvalues = scm_ilength (ret);
+      PUSH_LIST (ret, scm_is_null);
+      goto vm_return_values;
+    }
+  else
+    {
+      PUSH (ret);
+      goto vm_return;
+    }
+}
+
 VM_DEFINE_INSTRUCTION (56, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
 {
   SCM x;
@@ -975,7 +972,6 @@ VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 
1)
 
 VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
 {
-  SCM x;
   scm_t_int32 offset;
   scm_t_uint8 *mvra;
   
@@ -984,65 +980,38 @@ VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
   mvra = ip + offset;
 
  vm_mv_call:
-  x = sp[-nargs];
+  program = sp[-nargs];
 
   VM_HANDLE_INTERRUPTS;
 
-  /*
-   * Subprogram call
-   */
-  if (SCM_PROGRAM_P (x))
-    {
-      program = x;
-      CACHE_PROGRAM ();
-      fp = sp - nargs + 1;
-      ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
-      ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
-      SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
-      SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
-      ip = SCM_C_OBJCODE_BASE (bp);
-      ENTER_HOOK ();
-      APPLY_HOOK ();
-      NEXT;
-    }
-  if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
     {
-      sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
-      goto vm_mv_call;
-    }
-  /*
-   * Other interpreted or compiled call
-   */
-  if (!scm_is_false (scm_procedure_p (x)))
-    {
-      SCM ret;
-      /* At this point, the stack contains the frame, the procedure and each 
one
-        of its arguments. */
-      SYNC_REGISTER ();
-      ret = apply_foreign (sp[-nargs],
-                           sp - nargs + 1,
-                           nargs,
-                           vp->stack_limit - sp + 1);
-      NULLSTACK_FOR_NONLOCAL_EXIT ();
-      DROPN (nargs + 1); /* drop args and procedure */
-      DROP_FRAME ();
-      
-      if (SCM_VALUESP (ret))
+      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
+        {
+          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
+          goto vm_mv_call;
+        }
+      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+               && SCM_SMOB_APPLICABLE_P (program))
         {
-          SCM len;
-          ret = scm_struct_ref (ret, SCM_INUM0);
-          len = scm_length (ret);
-          PUSH_LIST (ret, scm_is_null);
-          PUSH (len);
-          ip = mvra;
+          SYNC_REGISTER ();
+          sp[-nargs] = scm_i_smob_apply_trampoline (program);
+          goto vm_mv_call;
         }
       else
-        PUSH (ret);
-      NEXT;
+        goto vm_error_wrong_type_apply;
     }
 
-  program = x;
-  goto vm_error_wrong_type_apply;
+  CACHE_PROGRAM ();
+  fp = sp - nargs + 1;
+  ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+  ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+  SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+  SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+  ip = SCM_C_OBJCODE_BASE (bp);
+  ENTER_HOOK ();
+  APPLY_HOOK ();
+  NEXT;
 }
 
 VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
diff --git a/libguile/vm.c b/libguile/vm.c
index 0da915b..a693c53 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -273,39 +273,6 @@ resolve_variable (SCM what, SCM program_module)
     }
 }
   
-static SCM
-apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
-{
-  SCM_ASRTGO (SCM_NIMP (proc), badproc);
-
-  switch (SCM_TYP7 (proc))
-    {
-    case scm_tc7_smob:
-      if (!SCM_SMOB_APPLICABLE_P (proc))
-        goto badproc;
-      switch (nargs)
-        {
-        case 0:
-          return SCM_SMOB_APPLY_0 (proc);
-        case 1:
-          return SCM_SMOB_APPLY_1 (proc, args[0]);
-        case 2:
-          return SCM_SMOB_APPLY_2 (proc, args[0], args[1]);
-        default:
-          {
-            SCM arglist = SCM_EOL;
-            while (nargs-- > 2)
-              arglist = scm_cons (args[nargs], arglist);
-            return SCM_SMOB_APPLY_3 (proc, args[0], args[1], arglist);
-          }
-        }
-    default:
-    badproc:
-      scm_wrong_type_arg ("apply", SCM_ARG1, proc);
-    }
-}
-
-
 #define VM_DEFAULT_STACK_SIZE  (64 * 1024)
 
 #define VM_NAME   vm_regular_engine


hooks/post-receive
-- 
GNU Guile




reply via email to

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