summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-01-09 14:12:47 +0100
committerAndy Wingo <wingo@pobox.com>2010-01-09 14:21:03 +0100
commit75c3ed282029f4d2a80adf75f52ec1b9b34edcb7 (patch)
tree1167bd621a5dda0a9466f4c0f51d6b363445d73d
parent9174596d5bfc456d06f4cf74a7a67e9b2b09aac3 (diff)
downloadguile-75c3ed282029f4d2a80adf75f52ec1b9b34edcb7.tar.gz
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.
-rw-r--r--libguile/procprop.c32
-rw-r--r--libguile/smob.c534
-rw-r--r--libguile/smob.h16
-rw-r--r--libguile/vm-i-system.c259
-rw-r--r--libguile/vm.c33
5 files changed, 397 insertions, 477 deletions
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 641defc49..b3c6c864c 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 442e6e484..171db8d0c 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -17,12 +17,6 @@
*/
-#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
-#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>
@@ -35,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>
@@ -123,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);
}
@@ -335,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
@@ -592,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 ()
@@ -630,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 a79c39c9c..07deebd27 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 546c9e09f..dab268f3a 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 0da915bc3..a693c53e3 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