diff options
-rw-r--r-- | libguile/foreign.c | 133 | ||||
-rw-r--r-- | libguile/foreign.h | 1 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 2 |
3 files changed, 135 insertions, 1 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index e15f6d5aa..e147c3d30 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -684,7 +684,140 @@ cif_to_procedure (SCM cif, SCM func_ptr) 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 diff --git a/libguile/foreign.h b/libguile/foreign.h index 8424cde4b..9bc047e65 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -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 arg_types); +SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, SCM *argv); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 3ddc7ea80..1c0aae5b6 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -959,7 +959,7 @@ VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1) VM_HANDLE_INTERRUPTS; 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 (); |