dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Support calling foreign functions of 10 arguments or more.

Browse source 
* 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.
This commit is contained in:
Mark H Weaver 2013-02-26 17:25:51 -05:00
commit 5ccc3764b3
3 changed files with 111 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

113
libguile/foreign.c
View file

@ -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 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(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 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
get_objcode_trampoline (unsigned int 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 >= 128 currently unimplemented",
SCM_EOL);
return objcode;
}
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
ffi_cif *c_cif;
unsigned int nargs;
SCM objcode, table, ret;
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
nargs = c_cif->nargs;
if (nargs < 10)
objcode = objcode_trampolines[nargs];
else
scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
SCM_EOL);
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));

15
test-suite/standalone/test-ffi
View file

@ -169,6 +169,21 @@ exec guile -q -s "$0" "$@"
(test (f-sum -1 2000 -30000 40000000000)
(+ -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
;;

17
test-suite/standalone/test-ffi-lib.c
View file

@ -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;