bug#13809: Wishlist: support > 10 args to foreign functions

bug#13809: Wishlist: support > 10 args to foreign functions

[Mark H Weaver]

The current limitation of 10 arguments to foreign functions is proving
to be a problem for some libraries, in particular the Allegro game
library.

Is there a reason why raising this limit to 16 or 20 would be
undesirable?  What tradeoffs are involved?

    Thanks,
      Mark

bug#13809: Wishlist: support > 10 args to foreign functions

[Andy Wingo]

On Mon 25 Feb 2013 01:34, Mark H Weaver <mhw@netris.org> writes:

> The current limitation of 10 arguments to foreign functions is proving
> to be a problem for some libraries, in particular the Allegro game
> library.
>
> Is there a reason why raising this limit to 16 or 20 would be
> undesirable?  What tradeoffs are involved?

Each arity of foreign functions gets a little VM program stub that
checks the argument count then actually does the call.  We statically
generate the first N of those arities (currently 10), and then for the
rest we should dynamically allocate the objcode stubs.  Dynamic
allocation is currently unimplemented.

We could raise the pregenerated size, but I think it would be better to
do the dynamic allocation thing.

Andy
-- 
http://wingolog.org/

bug#13809: [PATCH] Support calling foreign functions of 10 or more arguments

[Mark H Weaver]

[-- Attachment #1: Type: text/plain, Size: 849 bytes --]

Hi Andy,

Andy Wingo <wingo@pobox.com> writes:

> On Mon 25 Feb 2013 01:34, Mark H Weaver <mhw@netris.org> writes:
>
>> The current limitation of 10 arguments to foreign functions is proving
>> to be a problem for some libraries, in particular the Allegro game
>> library.
>>
>> Is there a reason why raising this limit to 16 or 20 would be
>> undesirable?  What tradeoffs are involved?
>
> Each arity of foreign functions gets a little VM program stub that
> checks the argument count then actually does the call.  We statically
> generate the first N of those arities (currently 10), and then for the
> rest we should dynamically allocate the objcode stubs.  Dynamic
> allocation is currently unimplemented.

I've attached a patch that implements dynamic allocation of objcode
stubs for larger arities.  What do you think?

   Thanks,
     Mark



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH] Support calling foreign functions of 10 or more arguments --]
[-- Type: text/x-diff, Size: 5562 bytes --]

From 29aaa7add08849503bde5a9be43b162e492a4297 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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

bug#13809: [PATCH] Support calling foreign functions of 10 or more arguments

[Andy Wingo]

Hi!

On Tue 26 Feb 2013 23:40, Mark H Weaver <mhw@netris.org> 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.

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.  As you like.

Andy
-- 
http://wingolog.org/

bug#13809: [PATCH] Support calling foreign functions of 10 or more arguments

[Mark H Weaver]

[-- Attachment #1: Type: text/plain, Size: 749 bytes --]

Hi Andy,

Andy Wingo <wingo@pobox.com> writes:
> On Tue 26 Feb 2013 23:40, Mark H Weaver <mhw@netris.org> 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



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH] Support calling foreign functions of 10 arguments or more --]
[-- Type: text/x-diff, Size: 9839 bytes --]

From ee83593fd502c5436025c4d4cfc8da2872c3be6a Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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

bug#13809: [PATCH] Support calling foreign functions of 10 or more arguments

[Andy Wingo]

Greets :)

On Wed 27 Feb 2013 23:11, Mark H Weaver <mhw@netris.org> writes:

> Also, I've since realized that the new arity limit is 127, not 255 as my
> previous patch had assumed.

Good catch.

> Here's a new patch.  What do you think?

Looks great, please apply.  Thank you!

Andy
-- 
http://wingolog.org/

bug#13809: [PATCH] Support calling foreign functions of 10 or more arguments

[Mark H Weaver]

Andy Wingo <wingo@pobox.com> writes:
> Looks great, please apply.  Thank you!

Pushed.  Thanks!

     Mark