make applicable smob calls cheaper, and fix a memory leak

* libguile/vm.c (prepare_smob_call): New helper.  Now, instead of making
  a per-smob trampoline, we will shuffle the smob into the args and use
  a gsubr.  This prevents a memory leak in which the trampolines, which
  were values in a weak-key table, were preventing the smobs from being
  collected.

* libguile/vm-i-system.c (call, tail-call, mv-call): Adapt to new smob
  application mechanism.
  (smob-call): Remove this instruction.

* libguile/smob.h (scm_smob_descriptor): Rename apply_trampoline_objcode
  to apply_trampoline.

* libguile/smob.c: Remove our own objcode trampolines in favor of using
  scm_c_make_gsubr.
  (scm_smob_prehistory): No more trampoline weak map.

* libguile/procprop.c (scm_i_procedure_arity): Adapt to applicable smob
  representation change.

1 files changed, 70 insertions, 255 deletions

diff --git a/libguile/smob.c b/libguile/smob.c
index e7975d03e..cbb3d7bb3 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -120,233 +120,81 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 /* {Apply}
  */
 
-#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
-
-/* 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)
+static SCM scm_smob_trampolines[16];
   
-#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
+/* (nargs * nargs) + nopt + rest * (nargs + 1) */
+#define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
+  scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
+                       + nopt + rest * (nreq + nopt + rest + 1)]
+
+static SCM
+apply_0 (SCM smob)
 {
-  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_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
-
-static const struct
+  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+  return subr (smob);
+}
+
+static SCM
+apply_1 (SCM smob, SCM a)
 {
-  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)
-};
+  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+  return subr (smob, a);
+}
 
-/* (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
+apply_2 (SCM smob, SCM a, SCM b)
+{
+  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+  return subr (smob, a, b);
+}
 
 static SCM
-scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
-                             unsigned int rest)
+apply_3 (SCM smob, SCM a, SCM b, SCM c)
 {
+  SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+  return subr (smob, a, b, c);
+}
+
+static SCM
+scm_smob_trampoline (unsigned int nreq, unsigned int nopt,
+                     unsigned int rest)
+{
+  SCM trampoline;
+
   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);
+  trampoline = SCM_SMOB_TRAMPOLINE (nreq, nopt, rest);
+
+  if (SCM_LIKELY (SCM_UNPACK (trampoline)))
+    return trampoline;
+
+  switch (nreq + nopt + rest)
+    {
+      /* The + 1 is for the smob itself.  */
+    case 0:
+      trampoline = scm_c_make_gsubr ("apply-smob/0", nreq + 1, nopt, rest,
+                                     apply_0);
+      break;
+    case 1:
+      trampoline = scm_c_make_gsubr ("apply-smob/1", nreq + 1, nopt, rest,
+                                     apply_1);
+      break;
+    case 2:
+      trampoline = scm_c_make_gsubr ("apply-smob/2", nreq + 1, nopt, rest,
+                                     apply_2);
+      break;
+    case 3:
+      trampoline = scm_c_make_gsubr ("apply-smob/3", nreq + 1, nopt, rest,
+                                     apply_3);
+      break;
+    default:
+      abort ();
+    }
+
+  SCM_SMOB_TRAMPOLINE (nreq, nopt, rest) = trampoline;
+
+  return trampoline;
 }
 
 
@@ -406,46 +254,15 @@ void
 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 		    unsigned int req, unsigned int opt, unsigned int rst)
 {
-  scm_smobs[SCM_TC2SMOBNUM (tc)].apply   = apply;
-  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
-    = scm_smob_objcode_trampoline (req, opt, rst);
+  SCM trampoline = scm_smob_trampoline (req, opt, rst);
+
+  scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
+  scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline = trampoline;
 
   if (SCM_UNPACK (scm_smob_class[0]) != 0)
     scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 }
 
-static SCM tramp_weak_map = SCM_BOOL_F;
-
-SCM
-scm_i_smob_apply_trampoline (SCM smob)
-{
-  SCM tramp;
-
-  tramp = scm_weak_table_refq (tramp_weak_map, smob, SCM_BOOL_F);
-
-  if (scm_is_true (tramp))
-    return tramp;
-  else
-    {
-      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_utf8_symbol (name));
-      tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
-                                objtable, SCM_BOOL_F);
-
-      /* Race conditions (between the ref and this set!) cannot cause
-         any harm here.  */
-      scm_weak_table_putq_x (tramp_weak_map, smob, tramp);
-      return tramp;
-    }
-}
-
 SCM
 scm_make_smob (scm_t_bits tc)
 {
@@ -652,10 +469,8 @@ scm_smob_prehistory ()
       scm_smobs[i].print      = scm_smob_print;
       scm_smobs[i].equalp     = 0;
       scm_smobs[i].apply      = 0;
-      scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
+      scm_smobs[i].apply_trampoline = SCM_BOOL_F;
     }
-
-  tramp_weak_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 }
 
 /*