[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-195-g80be163
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-195-g80be163 |
|
Date: |
Sun, 18 Mar 2012 19:11:27 +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=80be163f81e0dcc16e6805d4c2d1f2de3ca38c55
The branch, master has been updated
via 80be163f81e0dcc16e6805d4c2d1f2de3ca38c55 (commit)
from d5e1f8224068c3c579b9a6d77450d50af512aa52 (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 80be163f81e0dcc16e6805d4c2d1f2de3ca38c55
Author: Andy Wingo <address@hidden>
Date: Sun Mar 18 20:04:28 2012 +0100
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.
-----------------------------------------------------------------------
Summary of changes:
libguile/procprop.c | 8 +-
libguile/smob.c | 325 +++++++++++-------------------------------------
libguile/smob.h | 6 +-
libguile/vm-i-system.c | 59 +--------
libguile/vm.c | 18 +++
5 files changed, 103 insertions(+), 313 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 56bd389..8e234ed 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011, 2012 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
@@ -72,7 +72,11 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
{
if (!SCM_SMOB_APPLICABLE_P (proc))
return 0;
- proc = scm_i_smob_apply_trampoline (proc);
+ if (scm_i_program_arity (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline,
+ req, opt, rest))
+ /* The trampoline gets the smob too, which users don't
+ see. */
+ *req -= 1;
}
else
return 0;
diff --git a/libguile/smob.c b/libguile/smob.c
index e7975d0..cbb3d7b 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);
}
/*
diff --git a/libguile/smob.h b/libguile/smob.h
index be404a8..37ea642 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -4,7 +4,7 @@
#define SCM_SMOB_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2009,
- * 2010, 2011 Free Software Foundation, Inc.
+ * 2010, 2011, 2012 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,7 +40,7 @@ typedef struct scm_smob_descriptor
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM);
scm_t_subr apply;
- SCM apply_trampoline_objcode;
+ SCM apply_trampoline;
} scm_smob_descriptor;
@@ -196,8 +196,6 @@ 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 SCM scm_i_smob_apply_trampoline (SCM smob);
-
SCM_API void scm_smob_prehistory (void);
#endif /* SCM_SMOB_H */
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index bad4c30..7153ab5 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -803,8 +803,8 @@ VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
+ PUSH (program);
+ prepare_smob_call (sp, ++nargs, program);
goto vm_call;
}
else
@@ -851,8 +851,8 @@ VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1)
else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
+ PUSH (program);
+ prepare_smob_call (sp, ++nargs, program);
goto vm_tail_call;
}
else
@@ -952,52 +952,7 @@ VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1,
-1)
}
}
-VM_DEFINE_INSTRUCTION (58, 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 ();
-
- 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;
- }
-}
+/* Instruction 58 used to be smob-call. */
VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1)
{
@@ -1104,8 +1059,8 @@ VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
+ PUSH (program);
+ prepare_smob_call (sp, ++nargs, program);
goto vm_mv_call;
}
else
diff --git a/libguile/vm.c b/libguile/vm.c
index 4d32c95..5645f81 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -433,6 +433,24 @@ vm_make_boot_program (long nargs)
* VM
*/
+/* We are calling a SMOB. The calling code pushed the SMOB after the
+ args, and incremented nargs. That nargs is passed here. This
+ function's job is to replace the procedure with the trampoline, and
+ shuffle the smob itself to be argument 0. This function must not
+ allocate or throw, as the VM registers are not synchronized. */
+static void
+prepare_smob_call (SCM *sp, int nargs, SCM smob)
+{
+ SCM *args = sp - nargs + 1;
+
+ /* Shuffle args up. */
+ while (nargs--)
+ args[nargs + 1] = args[nargs];
+
+ args[0] = smob;
+ args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline;
+}
+
static SCM
resolve_variable (SCM what, SCM program_module)
{
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-195-g80be163,
Andy Wingo <=