mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

first pass at implementing low-level foreign functions

Browse source 
* libguile/Makefile.am (AM_CPPFLAGS): Move LIBFFI_CFLAGS here (from
  AM_CFLAGS), allowing snarfing to work.

* libguile/foreign.h (scm_make_foreign_function): New public function.

* libguile/foreign.c: Flesh out an implementation of foreign functions.
  (scm_take_foreign_pointer): Bugfix for the case in which we have a
  finalizer.

* module/system/foreign.scm: Export `make-foreign-function'.
This commit is contained in:
Andy Wingo 2010-01-25 18:15:35 +01:00
parent 827dc8dcb6
commit d8b04f04e9
4 changed files with 350 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/Makefile.am
View file

@ -33,9 +33,9 @@ DEFAULT_INCLUDES =
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building. Also look for Gnulib headers in `lib'.
AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
-I$(top_srcdir)/lib -I$(top_builddir)/lib $(LIBFFI_CFLAGS)
AM_CFLAGS = $(LIBFFI_CFLAGS) $(GCC_CFLAGS) $(CFLAG_VISIBILITY)
AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY)
## The Gnulib Libtool archive.
gnulib_library = $(top_builddir)/lib/libgnu.la

324
libguile/foreign.c
View file

@ -20,9 +20,13 @@
# include <config.h>
#endif
#include <ffi.h>
#include <alignof.h>
#include <string.h>
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
#include "libguile/instructions.h"
#include "libguile/foreign.h"
@ -39,6 +43,9 @@ SCM_SYMBOL (sym_int32, "int32");
SCM_SYMBOL (sym_uint64, "uint64");
SCM_SYMBOL (sym_int64, "int64");
static SCM cif_to_procedure (SCM cif, SCM func_ptr);
static SCM foreign_weak_refs = SCM_BOOL_F;
static void
@ -63,7 +70,7 @@ scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
| (finalizer ? (1<<16) : 0) | (len<<17));
if (SCM_UNLIKELY ((word0 >> 16) != len))
if (SCM_UNLIKELY ((word0 >> 17) != len))
scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
@ -363,6 +370,321 @@ scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
scm_putc ('>', port);
}
#define ROUND_UP(len,align) (align?(((len-1)|(align-1))+1):len)
/* return 1 on success, 0 on failure */
static int
parse_ffi_type (SCM type, int return_p, long *n_structs, long *n_struct_elts)
{
if (SCM_I_INUMP (type))
{
if ((SCM_I_INUM (type) < 0 )
|| (SCM_I_INUM (type) > SCM_FOREIGN_TYPE_LAST))
return 0;
else if (SCM_I_INUM (type) == SCM_FOREIGN_TYPE_VOID && !return_p)
return 0;
else
return 1;
}
else
{
long len;
len = scm_ilength (type);
if (len < 1)
return 0;
while (len--)
{
if (!parse_ffi_type (scm_car (type), 0, n_structs, n_struct_elts))
return 0;
(*n_struct_elts)++;
type = scm_cdr (type);
}
(*n_structs)++;
return 1;
}
}
static void
fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs,
ffi_type **types)
{
if (SCM_I_INUMP (type))
{
switch (SCM_I_INUM (type))
{
case SCM_FOREIGN_TYPE_FLOAT:
*ftype = ffi_type_float;
return;
case SCM_FOREIGN_TYPE_DOUBLE:
*ftype = ffi_type_double;
return;
case SCM_FOREIGN_TYPE_UINT8:
*ftype = ffi_type_uint8;
return;
case SCM_FOREIGN_TYPE_INT8:
*ftype = ffi_type_sint8;
return;
case SCM_FOREIGN_TYPE_UINT16:
*ftype = ffi_type_uint16;
return;
case SCM_FOREIGN_TYPE_INT16:
*ftype = ffi_type_sint16;
return;
case SCM_FOREIGN_TYPE_UINT32:
*ftype = ffi_type_uint32;
return;
case SCM_FOREIGN_TYPE_INT32:
*ftype = ffi_type_sint32;
return;
case SCM_FOREIGN_TYPE_UINT64:
*ftype = ffi_type_uint64;
return;
case SCM_FOREIGN_TYPE_INT64:
*ftype = ffi_type_sint64;
return;
case SCM_FOREIGN_TYPE_VOID:
*ftype = ffi_type_void;
return;
default:
abort ();
}
}
else
{
long i, len;
len = scm_ilength (type);
ftype->size = 0;
ftype->alignment = 0;
ftype->type = FFI_TYPE_STRUCT;
ftype->elements = *type_ptrs;
*type_ptrs += len + 1;
for (i = 0; i < len; i++)
{
ftype->elements[i] = *(types++);
fill_ffi_type (scm_car (type), ftype->elements[i],
type_ptrs, types);
type = scm_cdr (type);
}
ftype->elements[i] = NULL;
}
}
SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
(SCM return_type, SCM func_ptr, SCM arg_types),
"foo")
#define FUNC_NAME s_scm_make_foreign_function
{
SCM walk, scm_cif;
long i, nargs, n_structs, n_struct_elts;
size_t cif_len;
char *mem;
ffi_cif *cif;
ffi_type **type_ptrs;
ffi_type *types;
SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
nargs = scm_ilength (arg_types);
SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
/* fixme: assert nargs < 1<<32 */
n_structs = n_struct_elts = 0;
/* For want of talloc, we're going to have to do this in two passes: first we
figure out how much memory is needed for all types, then we allocate the
cif and the types all in one block. */
if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
scm_wrong_type_arg (FUNC_NAME, 1, return_type);
for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
/* the memory: with space for the cif itself */
cif_len = sizeof (ffi_cif);
/* then ffi_type pointers: one for each arg, one for each struct
element, and one for each struct (for null-termination) */
cif_len = (ROUND_UP (cif_len, alignof(void*))
+ (nargs + n_structs + n_struct_elts)*sizeof(void*));
/* then the ffi_type structs themselves, one per arg and struct element, and
one for the return val */
cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
+ (nargs + n_struct_elts + 1)*sizeof(ffi_type));
mem = scm_malloc (cif_len);
scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem, cif_len, free);
cif = (ffi_cif*)mem;
/* reuse cif_len to walk through the mem */
cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
type_ptrs = (ffi_type**)(mem + cif_len);
cif_len = ROUND_UP (cif_len
+ (nargs + n_structs + n_struct_elts)*sizeof(void*),
alignof(ffi_type));
types = (ffi_type*)(mem + cif_len);
/* whew. now knit the pointers together. */
cif->rtype = types++;
fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
cif->arg_types = type_ptrs;
type_ptrs += nargs;
for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
{
cif->arg_types[i] = types++;
fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
}
/* round out the cif, and we're done. */
cif->abi = FFI_DEFAULT_ABI;
cif->nargs = nargs;
cif->bytes = 0;
cif->flags = 0;
if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
cif->arg_types))
scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);
return cif_to_procedure (scm_cif, func_ptr);
}
#undef FUNC_NAME
/* 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
#else
#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 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 \
/* 32 */
static const struct
{
scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
+ sizeof (struct scm_objcode) + 32)];
} raw_bytecode = {
0,
{
CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
}
};
#undef CODE
#undef META
#undef OBJCODE_HEADER
#undef META_HEADER
/*
(defun generate-objcode-cells (n)
"Generate objcode cells for up to N arguments"
(interactive "p")
(let ((i 0))
(while (< i n)
(insert
(format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
(* (+ 4 4 8 4 4 32) i)))
(insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
(setq i (1+ i)))))
*/
#define STATIC_OBJCODE_TAG \
SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
static const struct
{
scm_t_uint64 dummy; /* alignment */
scm_t_cell cells[10 * 2]; /* 10 double cells */
} objcode_cells = {
0,
/* C-u 1 0 M-x generate-objcode-cells RET */
{
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
{ SCM_BOOL_F, SCM_PACK (0) },
{ STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
{ SCM_BOOL_F, SCM_PACK (0) }
}
};
static const SCM objcode_trampolines[10] = {
SCM_PACK (objcode_cells.cells+0),
SCM_PACK (objcode_cells.cells+2),
SCM_PACK (objcode_cells.cells+4),
SCM_PACK (objcode_cells.cells+6),
SCM_PACK (objcode_cells.cells+8),
SCM_PACK (objcode_cells.cells+10),
SCM_PACK (objcode_cells.cells+12),
SCM_PACK (objcode_cells.cells+14),
SCM_PACK (objcode_cells.cells+16),
SCM_PACK (objcode_cells.cells+18),
};
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs;
SCM objcode, table, ret;
if (nargs < 10)
objcode = objcode_trampolines[nargs];
else
abort ();
table = scm_c_make_vector (2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
ret = scm_make_program (objcode, table, SCM_BOOL_F);
return ret;
}
static void

23
libguile/foreign.h
View file

@ -98,6 +98,29 @@ SCM_API SCM scm_bytevector_to_foreign (SCM bv, SCM offset, SCM len);
SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
scm_print_state *pstate);
/* Foreign functions */
/* The goal is to make it so that calling a foreign function doesn't cause any
heap allocation. That means we need native Scheme formats for all kinds of
arguments.
For "value" types like s64 or f32, we just use native Scheme value types.
(Note that in both these cases, allocation is possible / likely, as the
value might need to be boxed, but perhaps we won't worry about that. Hmm.)
For everything else, we use foreign pointers. This includes arrays, pointer
arguments and return vals, struct args and return vals, and out and in/out
arguments.
*/
SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_INTERNAL void scm_register_foreign (void);

3
module/system/foreign.scm
View file

@ -25,6 +25,7 @@
uint64 int64
foreign-ref foreign-set!
foreign->bytevector bytevector->foreign))
foreign->bytevector bytevector->foreign
make-foreign-function))
(load-extension "libguile" "scm_init_foreign")