diff options
-rw-r--r-- | libguile/procprop.c | 12 | ||||
-rw-r--r-- | libguile/smob.c | 329 | ||||
-rw-r--r-- | libguile/smob.h | 3 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 14 | ||||
-rw-r--r-- | libguile/vm.c | 19 |
5 files changed, 107 insertions, 270 deletions
diff --git a/libguile/procprop.c b/libguile/procprop.c index 9a75254a2..36228d3f3 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -80,8 +80,16 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) return 0; - proc = scm_i_smob_apply_trampoline (proc); - break; + if (!scm_i_program_arity + (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline_objcode, + req, opt, rest)) + return 0; + + /* The trampoline gets the smob too, which users don't + see. */ + *req -= 1; + + return 1; case scm_tcs_struct: if (!SCM_STRUCT_APPLICABLE_P (proc)) return 0; diff --git a/libguile/smob.c b/libguile/smob.c index 6a341ef5d..1911460cf 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,51 +254,16 @@ 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; + /* In 2.2 this field is renamed to "apply_trampoline". */ + scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode = 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; -static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -SCM -scm_i_smob_apply_trampoline (SCM smob) -{ - SCM tramp; - - scm_i_pthread_mutex_lock (&tramp_lock); - tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F); - scm_i_pthread_mutex_unlock (&tramp_lock); - - 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); - - /* Race conditions (between the ref and this set!) cannot cause - any harm here. */ - scm_i_pthread_mutex_lock (&tramp_lock); - scm_hashq_set_x (tramp_weak_map, smob, tramp); - scm_i_pthread_mutex_unlock (&tramp_lock); - return tramp; - } -} - SCM scm_make_smob (scm_t_bits tc) { @@ -679,8 +492,6 @@ scm_smob_prehistory () scm_smobs[i].apply = 0; scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F; } - - tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED); } /* diff --git a/libguile/smob.h b/libguile/smob.h index cfe12c3b1..d4b7c6cea 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -40,6 +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; + /* In 2.2 this field is renamed to "apply_trampoline". */ SCM apply_trampoline_objcode; } scm_smob_descriptor; @@ -204,8 +205,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 474fe7883..21fa5a195 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc. +/* Copyright (C) 2001,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 @@ -790,8 +790,8 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) 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); + PUSH (program); + prepare_smob_call (sp, ++nargs, program); goto vm_call; } else @@ -838,8 +838,8 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) 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); + PUSH (program); + prepare_smob_call (sp, ++nargs, program); goto vm_tail_call; } else @@ -1099,8 +1099,8 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) 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); + PUSH (program); + prepare_smob_call (sp, ++nargs, program); goto vm_mv_call; } else diff --git a/libguile/vm.c b/libguile/vm.c index 8fae65604..d1c7bbcb0 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -423,6 +423,25 @@ 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; + /* apply_trampoline_objcode is actually a program. */ + args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode; +} + static SCM resolve_variable (SCM what, SCM program_module) { |