diff options
author | Mark H Weaver <mhw@netris.org> | 2013-03-28 05:09:53 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2013-03-28 05:09:53 -0400 |
commit | 26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0 (patch) | |
tree | 40f13bc6355adb822bb8cd01fee5bcd9fd5430f9 /libguile/foreign.c | |
parent | 8ae26afefee947c71314733c419519fb616bf36d (diff) | |
parent | 579127cce488ce208d62e68e679e34fbbdc17367 (diff) | |
download | guile-26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
configure.ac
libguile/deprecated.c
libguile/deprecated.h
libguile/filesys.h
libguile/fluids.c
libguile/fports.c
libguile/gc.c
libguile/guile.c
libguile/numbers.c
libguile/objcodes.c
libguile/r6rs-ports.c
libguile/smob.c
libguile/socket.c
libguile/threads.h
module/language/scheme/decompile-tree-il.scm
module/language/tree-il/peval.scm
test-suite/tests/syncase.test
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r-- | libguile/foreign.c | 115 |
1 files changed, 80 insertions, 35 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index c81c5f407..4f5aa58e1 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -770,37 +770,40 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, /* Pre-generate trampolines for less than 10 arguments. */ #ifdef WORDS_BIGENDIAN -#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40 -#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0 +#define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M (40) +#define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M (0) #else -#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0 -#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0 +#define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M (0) +#define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M (0) #endif -#define CODE(nreq) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \ - /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \ - /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \ - /* 7 */ scm_op_nop, \ - /* 8 */ META (3, 7, nreq) - -#define META(start, end, nreq) \ - 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_list, 0, 3, /* make a list of those 3 vals */ \ - /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \ - /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \ - /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \ - /* 24 */ scm_op_cons, /* make a pair for the properties */ \ - /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \ - /* 28 */ scm_op_return, /* and return */ \ - /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \ +#define GEN_CODE(M, nreq) \ + OBJCODE_HEADER (M), \ + /* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of args */ \ + /* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the function pointer */ \ + /* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as well) */ \ + /* 7 */ M (scm_op_nop), \ + /* 8 */ META (M, 3, 7, nreq) + +#define META(M, start, end, nreq) \ + META_HEADER (M), \ + /* 0 */ M (scm_op_make_eol), /* bindings */ \ + /* 1 */ M (scm_op_make_eol), /* sources */ \ + /* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /* arity: from ip N to ip N */ \ + /* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \ + /* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \ + /* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of that one list */ \ + /* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M ('M'), M ('e'), /* `name' */ \ + /* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \ + /* 24 */ M (scm_op_cons), /* make a pair for the properties */ \ + /* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and arities into list */ \ + /* 28 */ M (scm_op_return), /* and return */ \ + /* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \ /* 32 */ +#define M_STATIC(x) (x) +#define CODE(nreq) GEN_CODE (M_STATIC, nreq) + static const struct { scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */ @@ -814,8 +817,28 @@ static const struct } }; -#undef CODE +static SCM +make_objcode_trampoline (unsigned int nargs) +{ + const int size = sizeof (struct scm_objcode) + 8 + + sizeof (struct scm_objcode) + 32; + SCM bytecode = scm_c_make_bytevector (size); + scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode); + int i = 0; + +#define M_DYNAMIC(x) (bytes[i++] = (x)) + GEN_CODE (M_DYNAMIC, nargs); +#undef M_DYNAMIC + + if (i != size) + scm_syserror ("make_objcode_trampoline"); + return scm_bytecode_to_objcode (bytecode, SCM_UNDEFINED); +} + +#undef GEN_CODE #undef META +#undef M_STATIC +#undef CODE #undef OBJCODE_HEADER #undef META_HEADER @@ -878,21 +901,43 @@ static const SCM objcode_trampolines[10] = { SCM_PACK (objcode_cells.cells+18), }; +static SCM large_objcode_trampolines = SCM_UNDEFINED; +static scm_i_pthread_mutex_t large_objcode_trampolines_mutex = + SCM_I_PTHREAD_MUTEX_INITIALIZER; + static SCM -cif_to_procedure (SCM cif, SCM func_ptr) +get_objcode_trampoline (unsigned int nargs) { - ffi_cif *c_cif; - unsigned int nargs; - SCM objcode, table, ret; - - c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); - nargs = c_cif->nargs; + SCM objcode; if (nargs < 10) objcode = objcode_trampolines[nargs]; + else if (nargs < 128) + { + scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex); + if (SCM_UNBNDP (large_objcode_trampolines)) + large_objcode_trampolines = scm_c_make_vector (128, SCM_UNDEFINED); + objcode = scm_c_vector_ref (large_objcode_trampolines, nargs); + if (SCM_UNBNDP (objcode)) + scm_c_vector_set_x (large_objcode_trampolines, nargs, + objcode = make_objcode_trampoline (nargs)); + scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex); + } else - scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented", + scm_misc_error ("make-foreign-function", "args >= 128 currently unimplemented", SCM_EOL); + + return objcode; +} + +static SCM +cif_to_procedure (SCM cif, SCM func_ptr) +{ + ffi_cif *c_cif; + SCM objcode, table, ret; + + c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); + objcode = get_objcode_trampoline (c_cif->nargs); table = scm_c_make_vector (2, SCM_UNDEFINED); SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr)); |