mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 12:20:26 +02:00
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.
This commit is contained in:
Andy Wingo
parent
9174596d5b
commit
75c3ed2820
5 changed files with 399 additions and 479 deletions
|
|
@ -48,23 +48,27 @@ static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
|
||||||
int
|
int
|
||||||
scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
|
scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
|
||||||
{
|
{
|
||||||
if (SCM_IMP (proc))
|
while (!SCM_PROGRAM_P (proc))
|
||||||
return 0;
|
|
||||||
loop:
|
|
||||||
switch (SCM_TYP7 (proc))
|
|
||||||
{
|
{
|
||||||
case scm_tc7_program:
|
if (SCM_IMP (proc))
|
||||||
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))
|
|
||||||
return 0;
|
return 0;
|
||||||
proc = SCM_STRUCT_PROCEDURE (proc);
|
switch (SCM_TYP7 (proc))
|
||||||
goto loop;
|
{
|
||||||
default:
|
case scm_tc7_smob:
|
||||||
return 0;
|
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
|
/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
|
||||||
|
|
|
||||||
538
libguile/smob.c
538
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
|
#ifdef HAVE_CONFIG_H
|
||||||
# include <config.h>
|
# include <config.h>
|
||||||
|
|
@ -35,7 +29,9 @@
|
||||||
|
|
||||||
#include "libguile/async.h"
|
#include "libguile/async.h"
|
||||||
#include "libguile/goops.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
|
#ifdef HAVE_MALLOC_H
|
||||||
#include <malloc.h>
|
#include <malloc.h>
|
||||||
|
|
@ -123,159 +119,237 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
|
||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
/* {Apply}
|
/* {Apply}
|
||||||
*/
|
*/
|
||||||
|
|
||||||
#define SCM_SMOB_APPLY0(SMOB) \
|
#ifdef WORDS_BIGENDIAN
|
||||||
SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
|
#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
|
||||||
#define SCM_SMOB_APPLY1(SMOB, A1) \
|
#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
|
||||||
SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
|
#else
|
||||||
#define SCM_SMOB_APPLY2(SMOB, A1, A2) \
|
#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
|
||||||
SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
|
#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
|
||||||
#define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
|
#endif
|
||||||
SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
|
|
||||||
|
/* 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
|
static SCM
|
||||||
scm_smob_apply_0_010 (SCM smob)
|
scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
|
||||||
|
unsigned int rest)
|
||||||
{
|
{
|
||||||
return SCM_SMOB_APPLY1 (smob, 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
|
return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
|
||||||
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));
|
|
||||||
}
|
|
||||||
|
|
||||||
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);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -335,115 +409,42 @@ 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 (*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 = apply;
|
||||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
|
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
|
||||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
|
= scm_smob_objcode_trampoline (req, opt, rst);
|
||||||
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)
|
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)
|
||||||
|
{
|
||||||
|
/* 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
|
||||||
scm_make_smob (scm_t_bits tc)
|
scm_make_smob (scm_t_bits tc)
|
||||||
{
|
{
|
||||||
|
|
@ -592,21 +593,6 @@ scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
|
||||||
free_smob (smob);
|
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
|
void
|
||||||
scm_smob_prehistory ()
|
scm_smob_prehistory ()
|
||||||
|
|
@ -630,12 +616,10 @@ 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_0 = 0;
|
scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
|
||||||
scm_smobs[i].apply_1 = 0;
|
|
||||||
scm_smobs[i].apply_2 = 0;
|
|
||||||
scm_smobs[i].apply_3 = 0;
|
|
||||||
scm_smobs[i].gsubr_type = 0;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
|
||||||
}
|
}
|
||||||
|
|
||||||
/*
|
/*
|
||||||
|
|
|
||||||
|
|
@ -41,11 +41,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 (*apply) ();
|
SCM (*apply) ();
|
||||||
SCM (*apply_0) (SCM);
|
SCM apply_trampoline_objcode;
|
||||||
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_smob_descriptor;
|
} scm_smob_descriptor;
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -170,10 +166,10 @@ while (0)
|
||||||
#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj)
|
#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj)
|
||||||
#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
|
#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
|
||||||
#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply)
|
#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_0(x) (scm_call_0 (x))
|
||||||
#define SCM_SMOB_APPLY_1(x, a1) (SCM_SMOB_DESCRIPTOR (x).apply_1 (x, (a1)))
|
#define SCM_SMOB_APPLY_1(x, a1) (scm_call_1 (x, a1))
|
||||||
#define SCM_SMOB_APPLY_2(x, a1, a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2)))
|
#define SCM_SMOB_APPLY_2(x, a1, a2) (scm_call_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_3(x, a1, a2, rst) (scm_call_3 (x, a1, a2, a3))
|
||||||
|
|
||||||
/* Maximum number of SMOB types. */
|
/* Maximum number of SMOB types. */
|
||||||
#define SCM_I_MAX_SMOB_TYPE_COUNT 256
|
#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_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);
|
SCM_API void scm_smob_prehistory (void);
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -744,83 +744,70 @@ VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0, 3)
|
||||||
|
|
||||||
VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
|
VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
|
||||||
{
|
{
|
||||||
SCM x;
|
|
||||||
nargs = FETCH ();
|
nargs = FETCH ();
|
||||||
|
|
||||||
vm_call:
|
vm_call:
|
||||||
x = sp[-nargs];
|
program = sp[-nargs];
|
||||||
|
|
||||||
VM_HANDLE_INTERRUPTS;
|
VM_HANDLE_INTERRUPTS;
|
||||||
|
|
||||||
/*
|
if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
|
||||||
* Subprogram call
|
|
||||||
*/
|
|
||||||
if (SCM_PROGRAM_P (x))
|
|
||||||
{
|
{
|
||||||
program = x;
|
if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
|
||||||
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)))
|
|
||||||
{
|
{
|
||||||
/* truncate values */
|
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
|
||||||
ret = scm_struct_ref (ret, SCM_INUM0);
|
goto vm_call;
|
||||||
if (scm_is_null (ret))
|
}
|
||||||
goto vm_error_not_enough_values;
|
else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
|
||||||
PUSH (SCM_CAR (ret));
|
&& SCM_SMOB_APPLICABLE_P (program))
|
||||||
|
{
|
||||||
|
SYNC_REGISTER ();
|
||||||
|
sp[-nargs] = scm_i_smob_apply_trampoline (program);
|
||||||
|
goto vm_call;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
PUSH (ret);
|
goto vm_error_wrong_type_apply;
|
||||||
NEXT;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
program = x;
|
CACHE_PROGRAM ();
|
||||||
goto vm_error_wrong_type_apply;
|
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)
|
VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
|
||||||
{
|
{
|
||||||
register SCM x;
|
|
||||||
nargs = FETCH ();
|
nargs = FETCH ();
|
||||||
|
|
||||||
vm_tail_call:
|
vm_tail_call:
|
||||||
x = sp[-nargs];
|
program = sp[-nargs];
|
||||||
|
|
||||||
VM_HANDLE_INTERRUPTS;
|
VM_HANDLE_INTERRUPTS;
|
||||||
|
|
||||||
/*
|
if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
|
||||||
* Tail call
|
{
|
||||||
*/
|
if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
|
||||||
if (SCM_PROGRAM_P (x))
|
{
|
||||||
|
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;
|
int i;
|
||||||
#ifdef VM_ENABLE_STACK_NULLING
|
#ifdef VM_ENABLE_STACK_NULLING
|
||||||
|
|
@ -831,7 +818,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
|
||||||
EXIT_HOOK ();
|
EXIT_HOOK ();
|
||||||
|
|
||||||
/* switch programs */
|
/* switch programs */
|
||||||
program = x;
|
|
||||||
CACHE_PROGRAM ();
|
CACHE_PROGRAM ();
|
||||||
/* shuffle down the program and the arguments */
|
/* shuffle down the program and the arguments */
|
||||||
for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
|
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 ();
|
APPLY_HOOK ();
|
||||||
NEXT;
|
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)
|
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)
|
VM_DEFINE_INSTRUCTION (56, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
|
||||||
{
|
{
|
||||||
SCM x;
|
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)
|
VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
|
||||||
{
|
{
|
||||||
SCM x;
|
|
||||||
scm_t_int32 offset;
|
scm_t_int32 offset;
|
||||||
scm_t_uint8 *mvra;
|
scm_t_uint8 *mvra;
|
||||||
|
|
||||||
|
|
@ -984,65 +980,38 @@ VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
|
||||||
mvra = ip + offset;
|
mvra = ip + offset;
|
||||||
|
|
||||||
vm_mv_call:
|
vm_mv_call:
|
||||||
x = sp[-nargs];
|
program = sp[-nargs];
|
||||||
|
|
||||||
VM_HANDLE_INTERRUPTS;
|
VM_HANDLE_INTERRUPTS;
|
||||||
|
|
||||||
/*
|
if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
|
||||||
* Subprogram call
|
|
||||||
*/
|
|
||||||
if (SCM_PROGRAM_P (x))
|
|
||||||
{
|
{
|
||||||
program = x;
|
if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
|
||||||
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))
|
|
||||||
{
|
|
||||||
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;
|
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
|
||||||
ret = scm_struct_ref (ret, SCM_INUM0);
|
goto vm_mv_call;
|
||||||
len = scm_length (ret);
|
}
|
||||||
PUSH_LIST (ret, scm_is_null);
|
else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
|
||||||
PUSH (len);
|
&& SCM_SMOB_APPLICABLE_P (program))
|
||||||
ip = mvra;
|
{
|
||||||
|
SYNC_REGISTER ();
|
||||||
|
sp[-nargs] = scm_i_smob_apply_trampoline (program);
|
||||||
|
goto vm_mv_call;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
PUSH (ret);
|
goto vm_error_wrong_type_apply;
|
||||||
NEXT;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
program = x;
|
CACHE_PROGRAM ();
|
||||||
goto vm_error_wrong_type_apply;
|
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)
|
VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
|
||||||
|
|
|
||||||
|
|
@ -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_DEFAULT_STACK_SIZE (64 * 1024)
|
||||||
|
|
||||||
#define VM_NAME vm_regular_engine
|
#define VM_NAME vm_regular_engine
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue