mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

make applicable smob calls cheaper, and fix a memory leak

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2012-03-18 20:04:28 +01:00
parent d5e1f82240
commit 80be163f81
5 changed files with 105 additions and 315 deletions
Download patch file Download diff file Expand all files Collapse all files

8
libguile/procprop.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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)) if (!SCM_SMOB_APPLICABLE_P (proc))
return 0; 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 else
return 0; return 0;

329
libguile/smob.c
View file

@ -120,233 +120,81 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
/* {Apply} /* {Apply}
*/ */
#ifdef WORDS_BIGENDIAN static SCM scm_smob_trampolines[16];
#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)
#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_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
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) */ /* (nargs * nargs) + nopt + rest * (nargs + 1) */
#define SCM_SMOB_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \ #define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
scm_smob_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \ scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
+ nopt + rest * (nreq + nopt + rest + 1)] + nopt + rest * (nreq + nopt + rest + 1)]
static SCM static SCM
scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt, apply_0 (SCM smob)
unsigned int rest)
{ {
SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
return subr (smob);
}
static SCM
apply_1 (SCM smob, SCM a)
{
SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
return subr (smob, a);
}
static SCM
apply_2 (SCM smob, SCM a, SCM b)
{
SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
return subr (smob, a, b);
}
static SCM
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)) if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest)); 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) (), scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
unsigned int req, unsigned int opt, unsigned int rst) unsigned int req, unsigned int opt, unsigned int rst)
{ {
scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; SCM trampoline = scm_smob_trampoline (req, opt, rst);
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
= scm_smob_objcode_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) if (SCM_UNPACK (scm_smob_class[0]) != 0)
scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]); 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
scm_make_smob (scm_t_bits tc) scm_make_smob (scm_t_bits tc)
{ {
@ -652,10 +469,8 @@ scm_smob_prehistory ()
scm_smobs[i].print = scm_smob_print; scm_smobs[i].print = scm_smob_print;
scm_smobs[i].equalp = 0; scm_smobs[i].equalp = 0;
scm_smobs[i].apply = 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);
} }
/* /*

6
libguile/smob.h
View file

@ -4,7 +4,7 @@
#define SCM_SMOB_H #define SCM_SMOB_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2009, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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); int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM); SCM (*equalp) (SCM, SCM);
scm_t_subr apply; scm_t_subr apply;
SCM apply_trampoline_objcode; SCM apply_trampoline;
} scm_smob_descriptor; } 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_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); SCM_API void scm_smob_prehistory (void);
#endif /* SCM_SMOB_H */ #endif /* SCM_SMOB_H */

59
libguile/vm-i-system.c
View file

@ -803,8 +803,8 @@ VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
else if (SCM_HAS_TYP7 (program, scm_tc7_smob) else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program)) && SCM_SMOB_APPLICABLE_P (program))
{ {
SYNC_REGISTER (); PUSH (program);
sp[-nargs] = scm_i_smob_apply_trampoline (program); prepare_smob_call (sp, ++nargs, program);
goto vm_call; goto vm_call;
} }
else 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) else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program)) && SCM_SMOB_APPLICABLE_P (program))
{ {
SYNC_REGISTER (); PUSH (program);
sp[-nargs] = scm_i_smob_apply_trampoline (program); prepare_smob_call (sp, ++nargs, program);
goto vm_tail_call; goto vm_tail_call;
} }
else 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) /* Instruction 58 used to be smob-call. */
{
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;
}
}
VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1) 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) else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program)) && SCM_SMOB_APPLICABLE_P (program))
{ {
SYNC_REGISTER (); PUSH (program);
sp[-nargs] = scm_i_smob_apply_trampoline (program); prepare_smob_call (sp, ++nargs, program);
goto vm_mv_call; goto vm_mv_call;
} }
else else

18
libguile/vm.c
View file

@ -433,6 +433,24 @@ vm_make_boot_program (long nargs)
* VM * 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 static SCM
resolve_variable (SCM what, SCM program_module) resolve_variable (SCM what, SCM program_module)
{ {