From 29aaa7add08849503bde5a9be43b162e492a4297 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 26 Feb 2013 17:25:51 -0500 Subject: [PATCH] Support calling foreign functions of 10 or more arguments. * libguile/foreign.c (large_objcode_trampolines, large_objcode_trampolines_mutex): New static variables. (make_objcode_trampoline, get_objcode_trampoline): New static functions. (cif_to_procedure): Use 'get_objcode_trampoline'. (scm_init_foreign): Initialize 'large_objcode_trampolines'. * test-suite/standalone/test-ffi-lib.c (test_ffi_sum_many): New function. * test-suite/standalone/test-ffi: Add test. --- libguile/foreign.c | 59 ++++++++++++++++++++++++++++++---- test-suite/standalone/test-ffi | 15 +++++++++ test-suite/standalone/test-ffi-lib.c | 17 ++++++++++ 3 files changed, 84 insertions(+), 7 deletions(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index f5819c4..f8b88de 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -880,21 +880,64 @@ static const SCM objcode_trampolines[10] = { SCM_PACK (objcode_cells.cells+18), }; +static SCM large_objcode_trampolines; +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) +make_objcode_trampoline (unsigned int nargs) { - ffi_cif *c_cif; - unsigned int nargs; - SCM objcode, table, ret; + const int size = sizeof (struct scm_objcode) + 8 + + sizeof (struct scm_objcode) + 32; + const scm_t_uint8 *bytes_0 = raw_bytecode.bytes + 0; + const scm_t_uint8 *bytes_1 = raw_bytecode.bytes + size; + SCM bytecode = scm_c_make_bytevector (size); + scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode); + int i; + + for (i = 0; i < size; i++) + { + if (bytes_0[i] == bytes_1[i]) + bytes[i] = bytes_0[i]; + else if (bytes_0[i] == 0 && bytes_1[i] == 1) + bytes[i] = nargs; + else + scm_syserror ("make_objcode_trampoline"); + } + return scm_bytecode_to_native_objcode (bytecode); +} - c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); - nargs = c_cif->nargs; +static SCM +get_objcode_trampoline (unsigned int nargs) +{ + SCM objcode; if (nargs < 10) objcode = objcode_trampolines[nargs]; + else if (nargs < 256) + { + scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex); + 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 >= 256 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)); @@ -1308,6 +1351,8 @@ scm_init_foreign (void) null_pointer = scm_cell (scm_tc7_pointer, 0); scm_define (sym_null, null_pointer); + + large_objcode_trampolines = scm_c_make_vector (256, SCM_UNDEFINED); } void diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi index ad68660..0a91f63 100755 --- a/test-suite/standalone/test-ffi +++ b/test-suite/standalone/test-ffi @@ -170,6 +170,21 @@ exec guile -q -s "$0" "$@" (+ -1 2000 -30000 40000000000)) ;; +;; More than ten arguments +;; +(define f-sum-many + (pointer->procedure int64 (dynamic-func "test_ffi_sum_many" lib) + (list uint8 uint16 uint32 uint64 + int8 int16 int32 int64 + int8 int16 int32 int64))) +(test (f-sum-many 255 65535 4294967295 1844674407370955161 + -1 2000 -30000 40000000000 + 5 -6000 70000 -80000000000) + (+ 255 65535 4294967295 1844674407370955161 + -1 2000 -30000 40000000000 + 5 -6000 70000 -80000000000)) + +;; ;; Structs ;; (define f-sum-struct diff --git a/test-suite/standalone/test-ffi-lib.c b/test-suite/standalone/test-ffi-lib.c index 37d6e43..f265339 100644 --- a/test-suite/standalone/test-ffi-lib.c +++ b/test-suite/standalone/test-ffi-lib.c @@ -194,6 +194,23 @@ scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b, } +scm_t_int64 test_ffi_sum_many (scm_t_uint8 a, scm_t_uint16 b, + scm_t_uint32 c, scm_t_uint64 d, + scm_t_int8 e, scm_t_int16 f, + scm_t_int32 g, scm_t_int64 h, + scm_t_int8 i, scm_t_int16 j, + scm_t_int32 k, scm_t_int64 l); +scm_t_int64 test_ffi_sum_many (scm_t_uint8 a, scm_t_uint16 b, + scm_t_uint32 c, scm_t_uint64 d, + scm_t_int8 e, scm_t_int16 f, + scm_t_int32 g, scm_t_int64 h, + scm_t_int8 i, scm_t_int16 j, + scm_t_int32 k, scm_t_int64 l) +{ + return l + k + j + i + h + g + f + e + d + c + b + a; +} + + struct foo { scm_t_int8 a; -- 1.7.10.4