From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.bugs Subject: bug#13809: [PATCH] Support calling foreign functions of 10 or more arguments Date: Wed, 27 Feb 2013 17:11:18 -0500 Message-ID: <87ppzlxv95.fsf__25530.2571262748$1362003788$gmane$org@tines.lan> References: <87621h6xkl.fsf@tines.lan> <87a9qs937u.fsf@pobox.com> <878v6azol2.fsf_-_@tines.lan> <87fw0ixg4p.fsf@pobox.com> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1362003764 31866 80.91.229.3 (27 Feb 2013 22:22:44 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Wed, 27 Feb 2013 22:22:44 +0000 (UTC) Cc: 13809@debbugs.gnu.org, guile-devel@gnu.org To: Andy Wingo Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Wed Feb 27 23:23:07 2013 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1UApOz-000352-Rf for guile-bugs@m.gmane.org; Wed, 27 Feb 2013 23:23:06 +0100 Original-Received: from localhost ([::1]:50286 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UApOb-0000Iu-M3 for guile-bugs@m.gmane.org; Wed, 27 Feb 2013 17:22:41 -0500 Original-Received: from eggs.gnu.org ([208.118.235.92]:55462) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UApOI-0000Ge-KG for bug-guile@gnu.org; Wed, 27 Feb 2013 17:22:37 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UApO5-0007ZT-7V for bug-guile@gnu.org; Wed, 27 Feb 2013 17:22:17 -0500 Original-Received: from debbugs.gnu.org ([140.186.70.43]:48709) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UApES-0004uH-So for bug-guile@gnu.org; Wed, 27 Feb 2013 17:12:12 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.72) (envelope-from ) id 1UApGD-00007J-Qp for bug-guile@gnu.org; Wed, 27 Feb 2013 17:14:01 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Mark H Weaver Original-Sender: debbugs-submit-bounces@debbugs.gnu.org Resent-CC: bug-guile@gnu.org Resent-Date: Wed, 27 Feb 2013 22:14:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 13809 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 13809-submit@debbugs.gnu.org id=B13809.1362003214404 (code B ref 13809); Wed, 27 Feb 2013 22:14:01 +0000 Original-Received: (at 13809) by debbugs.gnu.org; 27 Feb 2013 22:13:34 +0000 Original-Received: from localhost ([127.0.0.1]:54172 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.72) (envelope-from ) id 1UApFl-00006S-I5 for submit@debbugs.gnu.org; Wed, 27 Feb 2013 17:13:34 -0500 Original-Received: from world.peace.net ([96.39.62.75]:34908) by debbugs.gnu.org with esmtp (Exim 4.72) (envelope-from ) id 1UApFj-00006J-2f for 13809@debbugs.gnu.org; Wed, 27 Feb 2013 17:13:32 -0500 Original-Received: from 209-6-91-212.c3-0.smr-ubr1.sbo-smr.ma.cable.rcn.com ([209.6.91.212] helo=tines.lan) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1UApDj-0007m9-Cp; Wed, 27 Feb 2013 17:11:27 -0500 In-Reply-To: <87fw0ixg4p.fsf@pobox.com> (Andy Wingo's message of "Wed, 27 Feb 2013 10:25:42 +0100") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.2 (gnu/linux) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.13 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 140.186.70.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.bugs:6801 Archived-At: --=-=-= Content-Type: text/plain Hi Andy, Andy Wingo writes: > On Tue 26 Feb 2013 23:40, Mark H Weaver writes: > >> I've attached a patch that implements dynamic allocation of objcode >> stubs for larger arities. What do you think? > > LGTM. Please lazily initialize the vector as well. Okay. > If you like, CODE and META could probably be reworked as higher-order > macros so that they can both generate static objcodes and initialize a > non-static byte array. A bit more DRY. Although it makes the macros a bit uglier, I agree that this is a superior approach. Done. Also, I've since realized that the new arity limit is 127, not 255 as my previous patch had assumed. Here's a new patch. What do you think? Thanks, Mark --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Support-calling-foreign-functions-of-10-arguments-or.patch Content-Description: [PATCH] Support calling foreign functions of 10 arguments or more >From ee83593fd502c5436025c4d4cfc8da2872c3be6a 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 arguments or more. * libguile/foreign.c (OBJCODE_HEADER, META_HEADER, META): Change these into higher-order macros. (GEN_CODE): New higher-order macro based on 'CODE'. (M_STATIC, M_DYNAMIC): New macros. (CODE): Reimplement using 'GEN_CODE' and 'M_STATIC'. (make_objcode_trampoline): New static function. (large_objcode_trampolines, large_objcode_trampolines_mutex): New static variables. (get_objcode_trampoline): New static function. (cif_to_procedure): Use 'get_objcode_trampoline'. * test-suite/standalone/test-ffi-lib.c (test_ffi_sum_many): New function. * test-suite/standalone/test-ffi: Add test. --- libguile/foreign.c | 115 +++++++++++++++++++++++----------- test-suite/standalone/test-ffi | 15 +++++ test-suite/standalone/test-ffi-lib.c | 17 +++++ 3 files changed, 112 insertions(+), 35 deletions(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index f5819c4..90a4fca 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -772,37 +772,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 */ @@ -816,8 +819,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_native_objcode (bytecode); +} + +#undef GEN_CODE #undef META +#undef M_STATIC +#undef CODE #undef OBJCODE_HEADER #undef META_HEADER @@ -880,21 +903,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)); 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 --=-=-=--