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

smobs are applied with vm trampoline procedures

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-01-09 14:12:47 +01:00
parent 9174596d5b
commit 75c3ed2820
5 changed files with 399 additions and 479 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/procprop.c
View file

@ -47,25 +47,29 @@ 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)
{
while (!SCM_PROGRAM_P (proc))
{
if (SCM_IMP (proc))
return 0;
loop:
switch (SCM_TYP7 (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);
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);
goto loop;
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
other means; for example subrs have their own property slot, which is unused

524
libguile/smob.c
View file

@ -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)
#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_0_010 (SCM smob)
/* 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
{
return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
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)
}
};
static SCM
scm_smob_apply_0_020 (SCM smob)
#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
{
return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
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_0_030 (SCM smob)
scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
unsigned int rest)
{
return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
}
if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));
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));
}
static SCM
scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
{
return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
}
static SCM
scm_smob_apply_3_error (SCM smob,
SCM a1 SCM_UNUSED,
SCM a2 SCM_UNUSED,
SCM rst SCM_UNUSED)
{
scm_wrong_num_args (smob);
return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
}
@ -335,115 +409,42 @@ 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;
}
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;
}
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;
}
switch (type)
{
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;
}
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;
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
= scm_smob_objcode_trampoline (req, opt, rst);
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)
{
/* 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);
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_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
scm_make_smob (scm_t_bits tc)
{
@ -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);
}
/*

16
libguile/smob.h
View file

@ -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);

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

@ -744,20 +744,31 @@ 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;
if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
{
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
goto vm_error_wrong_type_apply;
}
CACHE_PROGRAM ();
fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
@ -769,58 +780,34 @@ VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
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)))
{
/* truncate values */
ret = scm_struct_ref (ret, SCM_INUM0);
if (scm_is_null (ret))
goto vm_error_not_enough_values;
PUSH (SCM_CAR (ret));
}
else
PUSH (ret);
NEXT;
}
program = x;
goto vm_error_wrong_type_apply;
}
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,16 +980,28 @@ 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))
if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
{
program = x;
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))
{
SYNC_REGISTER ();
sp[-nargs] = scm_i_smob_apply_trampoline (program);
goto vm_mv_call;
}
else
goto vm_error_wrong_type_apply;
}
CACHE_PROGRAM ();
fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
@ -1005,45 +1013,6 @@ VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
APPLY_HOOK ();
NEXT;
}
if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
{
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))
{
SCM len;
ret = scm_struct_ref (ret, SCM_INUM0);
len = scm_length (ret);
PUSH_LIST (ret, scm_is_null);
PUSH (len);
ip = mvra;
}
else
PUSH (ret);
NEXT;
}
program = x;
goto vm_error_wrong_type_apply;
}
VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
{

33
libguile/vm.c
View file

@ -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