mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-28 07:50:20 +02:00
implement foreign-call
* libguile/foreign.h: * libguile/foreign.c (scm_i_foreign_call): New internal function, actually implementing foreign calls. Untested. * libguile/vm-i-system.c (foreign-call): Wire up the call to scm_i_foreign_call.
This commit is contained in:
parent
d8b04f04e9
commit
4d9130a5b7
3 changed files with 135 additions and 1 deletions
|
@ -684,7 +684,140 @@ cif_to_procedure (SCM cif, SCM func_ptr)
|
||||||
return ret;
|
return ret;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static void
|
||||||
|
unpack (ffi_type *type, void *loc, SCM x)
|
||||||
|
{
|
||||||
|
switch (type->type)
|
||||||
|
{
|
||||||
|
case FFI_TYPE_FLOAT:
|
||||||
|
*(float*)loc = scm_to_double (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_DOUBLE:
|
||||||
|
*(double*)loc = scm_to_double (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_UINT8:
|
||||||
|
*(scm_t_uint8*)loc = scm_to_uint8 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_SINT8:
|
||||||
|
*(scm_t_int8*)loc = scm_to_int8 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_UINT16:
|
||||||
|
*(scm_t_uint16*)loc = scm_to_uint16 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_SINT16:
|
||||||
|
*(scm_t_int16*)loc = scm_to_int16 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_UINT32:
|
||||||
|
*(scm_t_uint32*)loc = scm_to_uint32 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_SINT32:
|
||||||
|
*(scm_t_int32*)loc = scm_to_int32 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_UINT64:
|
||||||
|
*(scm_t_uint64*)loc = scm_to_uint64 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_SINT64:
|
||||||
|
*(scm_t_int64*)loc = scm_to_int64 (x);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_STRUCT:
|
||||||
|
if (!SCM_FOREIGN_TYPED_P (x, VOID))
|
||||||
|
abort ();
|
||||||
|
if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
|
||||||
|
abort ();
|
||||||
|
memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
|
||||||
|
break;
|
||||||
|
case FFI_TYPE_POINTER:
|
||||||
|
if (!SCM_FOREIGN_TYPED_P (x, VOID))
|
||||||
|
abort ();
|
||||||
|
*(void**)loc = SCM_FOREIGN_POINTER (x, void);
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
abort ();
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
static SCM
|
||||||
|
pack (ffi_type *type, void *loc)
|
||||||
|
{
|
||||||
|
switch (type->type)
|
||||||
|
{
|
||||||
|
case FFI_TYPE_VOID:
|
||||||
|
return SCM_UNSPECIFIED;
|
||||||
|
case FFI_TYPE_FLOAT:
|
||||||
|
return scm_from_double (*(float*)loc);
|
||||||
|
case FFI_TYPE_DOUBLE:
|
||||||
|
return scm_from_double (*(double*)loc);
|
||||||
|
case FFI_TYPE_UINT8:
|
||||||
|
return scm_from_uint8 (*(scm_t_uint8*)loc);
|
||||||
|
case FFI_TYPE_SINT8:
|
||||||
|
return scm_from_int8 (*(scm_t_int8*)loc);
|
||||||
|
case FFI_TYPE_UINT16:
|
||||||
|
return scm_from_uint16 (*(scm_t_uint16*)loc);
|
||||||
|
case FFI_TYPE_SINT16:
|
||||||
|
return scm_from_int16 (*(scm_t_int16*)loc);
|
||||||
|
case FFI_TYPE_UINT32:
|
||||||
|
return scm_from_uint32 (*(scm_t_uint32*)loc);
|
||||||
|
case FFI_TYPE_SINT32:
|
||||||
|
return scm_from_int32 (*(scm_t_int32*)loc);
|
||||||
|
case FFI_TYPE_UINT64:
|
||||||
|
return scm_from_uint64 (*(scm_t_uint64*)loc);
|
||||||
|
case FFI_TYPE_SINT64:
|
||||||
|
return scm_from_int64 (*(scm_t_int64*)loc);
|
||||||
|
case FFI_TYPE_STRUCT:
|
||||||
|
{
|
||||||
|
void *mem = scm_malloc (type->size);
|
||||||
|
memcpy (mem, loc, type->size);
|
||||||
|
return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
|
||||||
|
mem, type->size, free);
|
||||||
|
}
|
||||||
|
case FFI_TYPE_POINTER:
|
||||||
|
return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
|
||||||
|
*(void**)loc, 0, NULL);
|
||||||
|
default:
|
||||||
|
abort ();
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
scm_i_foreign_call (SCM foreign, SCM *argv)
|
||||||
|
{
|
||||||
|
/* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
|
||||||
|
objtable. */
|
||||||
|
ffi_cif *cif;
|
||||||
|
void (*func)();
|
||||||
|
scm_t_uint8 *data;
|
||||||
|
void *rvalue;
|
||||||
|
void **args;
|
||||||
|
unsigned i;
|
||||||
|
scm_t_ptrdiff off;
|
||||||
|
|
||||||
|
cif = SCM_FOREIGN_POINTER (scm_car (foreign), ffi_cif);
|
||||||
|
func = SCM_FOREIGN_POINTER (scm_cdr (foreign), void);
|
||||||
|
|
||||||
|
/* arg pointers */
|
||||||
|
args = alloca (sizeof(void*) * cif->nargs);
|
||||||
|
/* arg values, then return type value */
|
||||||
|
data = alloca (ROUND_UP (cif->bytes, cif->rtype->alignment)
|
||||||
|
+ cif->rtype->size);
|
||||||
|
/* unpack argv to native values, setting argv pointers */
|
||||||
|
off = 0;
|
||||||
|
for (i = 0; i < cif->nargs; i++)
|
||||||
|
{
|
||||||
|
off = ROUND_UP (off, cif->arg_types[i]->alignment);
|
||||||
|
args[i] = data + off;
|
||||||
|
unpack (cif->arg_types[i], args[i], argv[i]);
|
||||||
|
off += cif->arg_types[i]->size;
|
||||||
|
}
|
||||||
|
/* prep space for the return value */
|
||||||
|
off = ROUND_UP (off, cif->rtype->alignment);
|
||||||
|
rvalue = data + off;
|
||||||
|
|
||||||
|
/* off we go! */
|
||||||
|
ffi_call (cif, func, rvalue, args);
|
||||||
|
|
||||||
|
return pack (cif->rtype, rvalue);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
static void
|
static void
|
||||||
|
|
|
@ -118,6 +118,7 @@ SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
|
||||||
|
|
||||||
SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
|
SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
|
||||||
SCM arg_types);
|
SCM arg_types);
|
||||||
|
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, SCM *argv);
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -959,7 +959,7 @@ VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1)
|
||||||
VM_HANDLE_INTERRUPTS;
|
VM_HANDLE_INTERRUPTS;
|
||||||
SYNC_REGISTER ();
|
SYNC_REGISTER ();
|
||||||
|
|
||||||
ret = SCM_BOOL_F; /* scm_i_foreign_call (foreign, sp - nargs + 1); */
|
ret = scm_i_foreign_call (foreign, sp - nargs + 1);
|
||||||
|
|
||||||
NULLSTACK_FOR_NONLOCAL_EXIT ();
|
NULLSTACK_FOR_NONLOCAL_EXIT ();
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue