struct callback* callback_alloc(sexp ctx, sexp proc) {
struct callback* res = calloc(1, sizeof(struct callback));
res->closure = ffi_closure_alloc(sizeof(ffi_closure), &res->ptr);
if( res->closure ) {
if( ffi_prep_cif(&res->cif, FFI_DEFAULT_ABI, 0, &ffi_type_void, NULL) == FFI_OK ) {
if (ffi_prep_closure_loc(res->closure, &res->cif, invoke_closure,
res, res->ptr) == FFI_OK) {
res->ctx = ctx;
res->proc = proc;
/* great success */
} else {
macro_debug("prep_closure_loc failed");
}
} else {
macro_debug("prep_cif failed");
}
} else {
macro_debug("closure_alloc failed");
}
/* add a ref to proc */
sexp_preserve_object(ctx, proc);
/* TODO should we also increment ctx ref count ? */
return res;
}
int main (void)
{
ffi_cif cif;
void *code;
ffi_closure *pcl = ffi_closure_alloc(sizeof(ffi_closure), &code);
ffi_type* cls_struct_fields0[5];
ffi_type cls_struct_type0;
ffi_type* dbl_arg_types[5];
cls_struct_type0.size = 0;
cls_struct_type0.alignment = 0;
cls_struct_type0.type = FFI_TYPE_STRUCT;
cls_struct_type0.elements = cls_struct_fields0;
struct cls_struct_combined g_dbl = {4.0, 5.0, 1.0, 8.0};
cls_struct_fields0[0] = &ffi_type_float;
cls_struct_fields0[1] = &ffi_type_float;
cls_struct_fields0[2] = &ffi_type_float;
cls_struct_fields0[3] = &ffi_type_float;
cls_struct_fields0[4] = NULL;
dbl_arg_types[0] = &cls_struct_type0;
dbl_arg_types[1] = NULL;
if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1, &ffi_type_void, dbl_arg_types)
!= FFI_OK) abort();
if (ffi_prep_closure_loc(pcl, &cif, cls_struct_combined_gn, NULL, code)
!= FFI_OK) abort();
((void(*)(cls_struct_combined)) (code))(g_dbl);
exit(0);
}
STATIC mp_obj_t mod_ffi_callback(mp_obj_t rettype_in, mp_obj_t func_in, mp_obj_t paramtypes_in) {
const char *rettype = mp_obj_str_get_str(rettype_in);
int nparams = MP_OBJ_SMALL_INT_VALUE(mp_obj_len_maybe(paramtypes_in));
mp_obj_fficallback_t *o = m_new_obj_var(mp_obj_fficallback_t, ffi_type*, nparams);
o->base.type = &fficallback_type;
o->clo = ffi_closure_alloc(sizeof(ffi_closure), &o->func);
o->rettype = *rettype;
mp_obj_t iterable = mp_getiter(paramtypes_in);
mp_obj_t item;
int i = 0;
while ((item = mp_iternext(iterable)) != MP_OBJ_STOP_ITERATION) {
o->params[i++] = get_ffi_type(item);
}
int res = ffi_prep_cif(&o->cif, FFI_DEFAULT_ABI, nparams, char2ffi_type(*rettype), o->params);
if (res != FFI_OK) {
nlr_raise(mp_obj_new_exception_msg_varg(&mp_type_ValueError, "Error in ffi_prep_cif"));
}
res = ffi_prep_closure_loc(o->clo, &o->cif, call_py_func, func_in, o->func);
if (res != FFI_OK) {
nlr_raise(mp_obj_new_exception_msg_varg(&mp_type_ValueError, "ffi_prep_closure_loc"));
}
return o;
}
explicit bound_function(F function_) : function(std::move(function_)) {
std::array<ffi_type*, sizeof...(Args)> args;
args.fill(&ffi_type_sint);
ffi_prep_cif(&cif, FFI_DEFAULT_ABI, args.size(), &ffi_type_sint, args.data());
auto closure = ffi_closure_alloc(sizeof(ffi_closure), reinterpret_cast<void**>(&thunk));
ffi_prep_closure_loc(static_cast<ffi_closure*>(closure), &cif, &call, this, reinterpret_cast<void*>(thunk));
}
ffi_status
ffi_prep_closure (ffi_closure* closure,
ffi_cif* cif,
void (*fun)(ffi_cif*,void*,void**,void*),
void *user_data)
{
return ffi_prep_closure_loc (closure, cif, fun, user_data, closure);
}
static VALUE
initialize(int rbargc, VALUE argv[], VALUE self)
{
VALUE ret;
VALUE args;
VALUE abi;
fiddle_closure * cl;
ffi_cif * cif;
ffi_closure *pcl;
ffi_status result;
int i, argc;
if (2 == rb_scan_args(rbargc, argv, "21", &ret, &args, &abi))
abi = INT2NUM(FFI_DEFAULT_ABI);
Check_Type(args, T_ARRAY);
argc = RARRAY_LENINT(args);
TypedData_Get_Struct(self, fiddle_closure, &closure_data_type, cl);
cl->argv = (ffi_type **)xcalloc(argc + 1, sizeof(ffi_type *));
for (i = 0; i < argc; i++) {
int type = NUM2INT(RARRAY_PTR(args)[i]);
cl->argv[i] = INT2FFI_TYPE(type);
}
cl->argv[argc] = NULL;
rb_iv_set(self, "@ctype", ret);
rb_iv_set(self, "@args", args);
cif = &cl->cif;
pcl = cl->pcl;
result = ffi_prep_cif(cif, NUM2INT(abi), argc,
INT2FFI_TYPE(NUM2INT(ret)),
cl->argv);
if (FFI_OK != result)
rb_raise(rb_eRuntimeError, "error prepping CIF %d", result);
#ifndef DONT_USE_FFI_CLOSURE_ALLOC
result = ffi_prep_closure_loc(pcl, cif, callback,
(void *)self, cl->code);
#else
result = ffi_prep_closure(pcl, cif, callback, (void *)self);
cl->code = (void *)pcl;
mprotect(pcl, sizeof(pcl), PROT_READ | PROT_EXEC);
#endif
if (FFI_OK != result)
rb_raise(rb_eRuntimeError, "error prepping closure %d", result);
return self;
}
ikptr_t
ikrt_ffi_prepare_callback (ikptr_t s_data, ikpcb_t* pcb)
/* Prepare a Libffi's callback interface associated to a CIF and a
Scheme function. If successful return a pointer object referencing
the callback, else return false. A failure is probably an error
allocating memory with the system functions.
S_DATA must be a pair whose car is a pointer object of type
"ik_ffi_cif_t" and whose cdr is the Scheme function to be used by the
callback. */
{
#if FFI_CLOSURES
ffi_cif * cif;
void * callable_pointer;
ffi_closure * closure;
ik_callback_locative_t * callback_user_data;
ffi_status st;
cif = IK_POINTER_DATA_VOIDP(IK_CAR(s_data));
closure = ffi_closure_alloc(sizeof(ffi_closure), &callable_pointer);
#ifdef LIBFFI_ON_DARWIN
{ /* This is needed on some flavors of Darwin to make the generated
callback code executable. */
ikuword_t code_start = IK_ALIGN_TO_PREV_PAGE(callable_pointer);
ikuword_t code_end = IK_ALIGN_TO_NEXT_PAGE(FFI_TRAMPOLINE_SIZE+(-1)+(ikuword_t)callable_pointer);
int rv = mprotect((void*)code_start, code_end - code_start, PROT_READ|PROT_WRITE|PROT_EXEC);
if (rv)
fprintf(stderr, "*** Vicare warning: error mprotecting callback code page\n");
}
#endif
callback_user_data = malloc(sizeof(ik_callback_locative_t));
if (NULL == callback_user_data)
return IK_FALSE_OBJECT;
st = ffi_prep_closure_loc(closure, cif, generic_callback, callback_user_data, callable_pointer);
if (FFI_OK != st) {
free(callback_user_data);
return IK_FALSE_OBJECT;
}
/* Prepend this callback to the linked list of callbacks registered in
this process' PCB. The garbage collector uses this information not
to collect data still needed by the callbacks. */
callback_user_data->callable_pointer = callable_pointer;
callback_user_data->closure = closure;
callback_user_data->data = s_data;
callback_user_data->next = pcb->callbacks;
pcb->callbacks = callback_user_data;
/* Return a pointer to callable code. */
return ika_pointer_alloc(pcb, (ikuword_t)callable_pointer);
#else /* if FFI_CLOSURES */
return IK_FALSE_OBJECT;
#endif /* if FFI_CLOSURES */
}
mrb_value
cfunc_closure_initialize(mrb_state *mrb, mrb_value self)
{
struct cfunc_closure_data *data;
data = mrb_data_check_get_ptr(mrb, self, &cfunc_closure_data_type);
if (!data) {
data = mrb_malloc(mrb, sizeof(struct cfunc_closure_data));
}
data->refer = 0;
data->autofree = 0;
DATA_PTR(self) = data;
DATA_TYPE(self) = &cfunc_closure_data_type;
data->mrb = mrb;
data->closure = NULL;
data->arg_types = NULL;
mrb_value rettype_mrb, block, args_mrb;
mrb_get_args(mrb, "&oo", &block, &rettype_mrb, &args_mrb);
data->argc = RARRAY_LEN(args_mrb);
ffi_type *return_ffi_type = rclass_to_mrb_ffi_type(mrb, mrb_class_ptr(rettype_mrb))->ffi_type_value;
data->return_type = rettype_mrb;
data->arg_ffi_types = mrb_malloc(mrb, sizeof(ffi_type*) * data->argc);
data->arg_types = mrb_malloc(mrb, sizeof(mrb_value) * data->argc);
int i;
for (i = 0; i < data->argc; ++i) {
data->arg_types[i] = mrb_ary_ref(mrb, args_mrb, i);
data->arg_ffi_types[i] = rclass_to_mrb_ffi_type(mrb, mrb_class_ptr(data->arg_types[i]))->ffi_type_value;
}
mrb_iv_set(mrb, self, mrb_intern_cstr(data->mrb, "@block"), block);
void *closure_pointer = NULL;
data->closure = ffi_closure_alloc(sizeof(ffi_closure) + sizeof(void*), &closure_pointer);
data->cif = mrb_malloc(mrb, sizeof(ffi_cif));
if (data->closure) {
if (ffi_prep_cif(data->cif, FFI_DEFAULT_ABI, data->argc, return_ffi_type, data->arg_ffi_types) == FFI_OK) {
if (ffi_prep_closure_loc(data->closure, data->cif, cfunc_closure_call_binding, mrb_object(self), closure_pointer) == FFI_OK) {
set_cfunc_pointer_data((struct cfunc_type_data *)data, closure_pointer);
return self;
}
}
}
mrb_raise(mrb, E_SCRIPT_ERROR, "Internal FFI call error");
return mrb_nil_value();
}
void*
createAdjustor (int cconv,
StgStablePtr hptr,
StgFunPtr wptr,
char *typeString)
{
ffi_cif *cif;
ffi_type **arg_types;
nat n_args, i;
ffi_type *result_type;
ffi_closure *cl;
int r, abi;
void *code;
n_args = strlen(typeString) - 1;
cif = stgMallocBytes(sizeof(ffi_cif), "createAdjustor");
arg_types = stgMallocBytes(n_args * sizeof(ffi_type*), "createAdjustor");
result_type = char_to_ffi_type(typeString[0]);
for (i=0; i < n_args; i++) {
arg_types[i] = char_to_ffi_type(typeString[i+1]);
}
switch (cconv) {
#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
case 0: /* stdcall */
abi = FFI_STDCALL;
break;
#endif
case 1: /* ccall */
abi = FFI_DEFAULT_ABI;
break;
default:
barf("createAdjustor: convention %d not supported on this platform", cconv);
}
r = ffi_prep_cif(cif, abi, n_args, result_type, arg_types);
if (r != FFI_OK) barf("ffi_prep_cif failed: %d", r);
cl = allocateExec(sizeof(ffi_closure), &code);
if (cl == NULL) {
barf("createAdjustor: failed to allocate memory");
}
r = ffi_prep_closure_loc(cl, cif, (void*)wptr, hptr/*userdata*/, code);
if (r != FFI_OK) barf("ffi_prep_closure_loc failed: %d", r);
return (void*)code;
}
/**
* g_callable_info_prepare_closure:
* @callable_info: a callable info from a typelib
* @cif: a ffi_cif structure
* @callback: the ffi callback
* @user_data: data to be passed into the callback
*
* Prepares a callback for ffi invocation.
*
* Return value: the ffi_closure or NULL on error.
* The return value should be freed by calling g_callable_info_free_closure().
*/
ffi_closure *
g_callable_info_prepare_closure (GICallableInfo *callable_info,
ffi_cif *cif,
GIFFIClosureCallback callback,
gpointer user_data)
{
gpointer exec_ptr;
GIClosureWrapper *closure;
ffi_status status;
g_return_val_if_fail (callable_info != NULL, FALSE);
g_return_val_if_fail (cif != NULL, FALSE);
g_return_val_if_fail (callback != NULL, FALSE);
closure = ffi_closure_alloc (sizeof (GIClosureWrapper), &exec_ptr);
if (!closure)
{
g_warning ("could not allocate closure\n");
return NULL;
}
closure->writable_self = closure;
status = ffi_prep_cif (cif, FFI_DEFAULT_ABI,
g_callable_info_get_n_args (callable_info),
g_callable_info_get_ffi_return_type (callable_info),
g_callable_info_get_ffi_arg_types (callable_info));
if (status != FFI_OK)
{
g_warning ("ffi_prep_cif failed: %d\n", status);
ffi_closure_free (closure);
return NULL;
}
status = ffi_prep_closure_loc (&closure->ffi_closure, cif, callback, user_data, exec_ptr);
if (status != FFI_OK)
{
g_warning ("ffi_prep_closure failed: %d\n", status);
ffi_closure_free (closure);
return NULL;
}
/* Return exec_ptr, which points to the same underlying memory as
* closure, but via an executable-non-writable mapping.
*/
return exec_ptr;
}
static VALUE
function_init(VALUE self, VALUE rbFunctionInfo, VALUE rbProc)
{
Function* fn = NULL;
Data_Get_Struct(self, Function, fn);
fn->rbFunctionInfo = rbFunctionInfo;
Data_Get_Struct(fn->rbFunctionInfo, FunctionType, fn->info);
if (rb_obj_is_kind_of(rbProc, rbffi_PointerClass)) {
AbstractMemory* memory;
Data_Get_Struct(rbProc, AbstractMemory, memory);
fn->memory = *memory;
} else if (rb_obj_is_kind_of(rbProc, rb_cProc) || rb_respond_to(rbProc, id_call)) {
void* code;
ffi_status status;
fn->ffiClosure = ffi_closure_alloc(sizeof(*fn->ffiClosure), &code);
if (fn->ffiClosure == NULL) {
rb_raise(rb_eNoMemError, "Failed to allocate libffi closure");
}
status = ffi_prep_closure_loc(fn->ffiClosure, &fn->info->ffi_cif,
callback_invoke, fn, code);
if (status != FFI_OK) {
rb_raise(rb_eArgError, "ffi_prep_closure_loc failed");
}
fn->memory.address = code;
fn->memory.size = sizeof(*fn->ffiClosure);
fn->autorelease = true;
} else {
rb_raise(rb_eTypeError, "wrong argument type. Expected pointer or proc");
}
fn->rbProc = rbProc;
return self;
}
int main (void)
{
ffi_cif cif;
void *code;
ffi_closure *pcl = ffi_closure_alloc(sizeof(ffi_closure), &code);
ffi_type* arg_types[1];
arg_types[0] = NULL;
CHECK(ffi_prep_cif(&cif, 255, 0, &ffi_type_void,
arg_types) == FFI_BAD_ABI);
CHECK(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, &ffi_type_void,
arg_types) == FFI_OK);
cif.abi= 255;
CHECK(ffi_prep_closure_loc(pcl, &cif, dummy_fn, NULL, code) == FFI_BAD_ABI);
exit(0);
}
/*
* Class: kotlinx_cinterop_JvmCallbacksKt
* Method: ffiCreateClosure0
* Signature: (JLjava/lang/Object;)J
*/
JNIEXPORT jlong JNICALL Java_kotlinx_cinterop_JvmCallbacksKt_ffiCreateClosure0(JNIEnv *env, jclass cls, jlong ffiCif, jobject userData) {
jobject userDataGlobalRef = (*env)->NewGlobalRef(env, userData);
if (userDataGlobalRef == NULL) {
return (jlong)0;
}
assert(sizeof(jobject) == sizeof(void*)); // TODO: check statically
void* userDataPtr = (void*) userDataGlobalRef;
void* res;
ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &res);
if (closure == NULL) {
return (jlong)0;
}
ffi_status status = ffi_prep_closure_loc(closure, (ffi_cif*)ffiCif, ffi_fun, userDataPtr, res);
if (status != FFI_OK) {
return -(jlong)1;
}
return (jlong) res;
}
ffi_status
ffi_prep_raw_closure_loc (ffi_raw_closure* cl,
ffi_cif *cif,
void (*fun)(ffi_cif*,void*,ffi_raw*,void*),
void *user_data,
void *codeloc)
{
ffi_status status;
status = ffi_prep_closure_loc ((ffi_closure*) cl,
cif,
&ffi_translate_args,
codeloc,
codeloc);
if (status == FFI_OK)
{
cl->fun = fun;
cl->user_data = user_data;
}
return status;
}
int main()
{
ffi_cif cif;
ffi_type *args[1];
ffi_closure *closure;
int (*bound_puts)(char *);
int rc;
/* Allocate closure and bound_puts */
closure = ffi_closure_alloc(sizeof(ffi_closure), &bound_puts);
if (closure)
{
/* Initialize the argument info vectors */
args[0] = &ffi_type_pointer;
/* Initialize the cif */
if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1,
&ffi_type_uint, args) == FFI_OK)
{
/* Initialize the closure, setting stream to stdout */
if (ffi_prep_closure_loc(closure, &cif, puts_binding,
stdout, bound_puts) == FFI_OK)
{
rc = bound_puts("Hello World!");
/* rc now holds the result of the call to fputs */
}
}
}
/* Deallocate both closure, and bound_puts */
ffi_closure_free(closure);
return 0;
}
static void * unmarshal_callback(MVMThreadContext *tc, MVMObject *callback, MVMObject *sig_info) {
MVMNativeCallbackCacheHead *callback_data_head = NULL;
MVMNativeCallback **callback_data_handle;
MVMString *cuid;
if (!IS_CONCRETE(callback))
return NULL;
/* Try to locate existing cached callback info. */
callback = MVM_frame_find_invokee(tc, callback, NULL);
cuid = ((MVMCode *)callback)->body.sf->body.cuuid;
MVM_HASH_GET(tc, tc->native_callback_cache, cuid, callback_data_head);
if (!callback_data_head) {
callback_data_head = MVM_malloc(sizeof(MVMNativeCallbackCacheHead));
callback_data_head->head = NULL;
MVM_HASH_BIND(tc, tc->native_callback_cache, cuid, callback_data_head);
}
callback_data_handle = &(callback_data_head->head);
while (*callback_data_handle) {
if ((*callback_data_handle)->target == callback) /* found it, break */
break;
callback_data_handle = &((*callback_data_handle)->next);
}
if (!*callback_data_handle) {
/* First, build the MVMNativeCallback */
MVMCallsite *cs;
MVMObject *typehash;
MVMint64 num_info, i;
MVMNativeCallback *callback_data;
/* cb is a piece of executable memory we obtain from libffi. */
void *cb;
ffi_cif *cif;
ffi_closure *closure;
ffi_status status;
num_info = MVM_repr_elems(tc, sig_info);
/* We'll also build up a MoarVM callsite as we go. */
cs = MVM_calloc(1, sizeof(MVMCallsite));
cs->flag_count = num_info - 1;
cs->arg_flags = MVM_malloc(cs->flag_count * sizeof(MVMCallsiteEntry));
cs->arg_count = num_info - 1;
cs->num_pos = num_info - 1;
cs->has_flattening = 0;
cs->is_interned = 0;
cs->with_invocant = NULL;
callback_data = MVM_malloc(sizeof(MVMNativeCallback));
callback_data->num_types = num_info;
callback_data->typeinfos = MVM_malloc(num_info * sizeof(MVMint16));
callback_data->types = MVM_malloc(num_info * sizeof(MVMObject *));
callback_data->next = NULL;
cif = (ffi_cif *)MVM_malloc(sizeof(ffi_cif));
callback_data->convention = FFI_DEFAULT_ABI;
callback_data->ffi_arg_types = MVM_malloc(sizeof(ffi_type *) * (cs->arg_count ? cs->arg_count : 1));
/* Collect information about the return type. */
typehash = MVM_repr_at_pos_o(tc, sig_info, 0);
callback_data->types[0] = MVM_repr_at_key_o(tc, typehash, tc->instance->str_consts.typeobj);
callback_data->typeinfos[0] = MVM_nativecall_get_arg_type(tc, typehash, 1);
callback_data->ffi_ret_type = MVM_nativecall_get_ffi_type(tc, callback_data->typeinfos[0]);
for (i = 1; i < num_info; i++) {
typehash = MVM_repr_at_pos_o(tc, sig_info, i);
callback_data->types[i] = MVM_repr_at_key_o(tc, typehash, tc->instance->str_consts.typeobj);
callback_data->typeinfos[i] = MVM_nativecall_get_arg_type(tc, typehash, 0) & ~MVM_NATIVECALL_ARG_FREE_STR;
callback_data->ffi_arg_types[i - 1] = MVM_nativecall_get_ffi_type(tc, callback_data->typeinfos[i]);
switch (callback_data->typeinfos[i] & MVM_NATIVECALL_ARG_TYPE_MASK) {
case MVM_NATIVECALL_ARG_CHAR:
case MVM_NATIVECALL_ARG_SHORT:
case MVM_NATIVECALL_ARG_INT:
case MVM_NATIVECALL_ARG_LONG:
case MVM_NATIVECALL_ARG_LONGLONG:
cs->arg_flags[i - 1] = MVM_CALLSITE_ARG_INT;
break;
case MVM_NATIVECALL_ARG_UCHAR:
case MVM_NATIVECALL_ARG_USHORT:
case MVM_NATIVECALL_ARG_UINT:
case MVM_NATIVECALL_ARG_ULONG:
case MVM_NATIVECALL_ARG_ULONGLONG:
/* TODO: should probably be UINT, when we can support that. */
cs->arg_flags[i - 1] = MVM_CALLSITE_ARG_INT;
break;
case MVM_NATIVECALL_ARG_FLOAT:
case MVM_NATIVECALL_ARG_DOUBLE:
cs->arg_flags[i - 1] = MVM_CALLSITE_ARG_NUM;
break;
default:
cs->arg_flags[i - 1] = MVM_CALLSITE_ARG_OBJ;
break;
}
}
MVM_callsite_try_intern(tc, &cs);
callback_data->instance = tc->instance;
callback_data->cs = cs;
callback_data->target = callback;
status = ffi_prep_cif(cif, callback_data->convention, (unsigned int)cs->arg_count,
callback_data->ffi_ret_type, callback_data->ffi_arg_types);
closure = ffi_closure_alloc(sizeof(ffi_closure), &cb);
if (!closure)
MVM_panic(1, "Unable to allocate memory for callback closure");
ffi_prep_closure_loc(closure, cif, callback_handler, callback_data, cb);
callback_data->cb = cb;
/* Now insert the MVMCallback into the linked list. */
*callback_data_handle = callback_data;
}
return (*callback_data_handle)->cb;
}
CThunkObject *_ctypes_alloc_callback(PyObject *callable,
PyObject *converters,
PyObject *restype,
int flags)
{
int result;
CThunkObject *p;
Py_ssize_t nArgs, i;
ffi_abi cc;
nArgs = PySequence_Size(converters);
p = CThunkObject_new(nArgs);
if (p == NULL)
return NULL;
assert(CThunk_CheckExact((PyObject *)p));
p->pcl_write = ffi_closure_alloc(sizeof(ffi_closure),
&p->pcl_exec);
if (p->pcl_write == NULL) {
PyErr_NoMemory();
goto error;
}
p->flags = flags;
for (i = 0; i < nArgs; ++i) {
PyObject *cnv = PySequence_GetItem(converters, i);
if (cnv == NULL)
goto error;
p->atypes[i] = _ctypes_get_ffi_type(cnv);
Py_DECREF(cnv);
}
p->atypes[i] = NULL;
Py_INCREF(restype);
p->restype = restype;
if (restype == Py_None) {
p->setfunc = NULL;
p->ffi_restype = &ffi_type_void;
} else {
StgDictObject *dict = PyType_stgdict(restype);
if (dict == NULL || dict->setfunc == NULL) {
PyErr_SetString(PyExc_TypeError,
"invalid result type for callback function");
goto error;
}
p->setfunc = dict->setfunc;
p->ffi_restype = &dict->ffi_type_pointer;
}
cc = FFI_DEFAULT_ABI;
#if defined(MS_WIN32) && !defined(_WIN32_WCE) && !defined(MS_WIN64)
if ((flags & FUNCFLAG_CDECL) == 0)
cc = FFI_STDCALL;
#endif
result = ffi_prep_cif(&p->cif, cc,
Py_SAFE_DOWNCAST(nArgs, Py_ssize_t, int),
_ctypes_get_ffi_type(restype),
&p->atypes[0]);
if (result != FFI_OK) {
PyErr_Format(PyExc_RuntimeError,
"ffi_prep_cif failed with %d", result);
goto error;
}
#if defined(X86_DARWIN) || defined(POWERPC_DARWIN)
result = ffi_prep_closure(p->pcl_write, &p->cif, closure_fcn, p);
#else
result = ffi_prep_closure_loc(p->pcl_write, &p->cif, closure_fcn,
p,
p->pcl_exec);
#endif
if (result != FFI_OK) {
PyErr_Format(PyExc_RuntimeError,
"ffi_prep_closure failed with %d", result);
goto error;
}
Py_INCREF(converters);
p->converters = converters;
Py_INCREF(callable);
p->callable = callable;
return p;
error:
Py_XDECREF(p);
return NULL;
}
static int generate_native_callback(WORD_LIST *list)
{
int nargs;
void *callback;
ffi_cif *cif;
ffi_closure *closure;
ffi_type **argtypes;
ffi_type *rettype;
char **proto;
char *resultname = "DLRETVAL";
char opt;
reset_internal_getopt();
// $ dlcall [-a abi] [-r type] [-n name]
while ((opt = internal_getopt(list, "a:r:n:")) != -1) {
switch (opt) {
case 'n':
resultname = list_optarg;
break;
default:
builtin_usage();
return EX_USAGE;
}
}
// Skip past any options.
if ((list = loptend) == NULL || !list->next) {
builtin_usage();
return EX_USAGE;
}
closure = ffi_closure_alloc(sizeof(ffi_closure), &callback);
cif = malloc(sizeof(ffi_cif));
argtypes = NULL;
proto = malloc(sizeof(char *));
proto[0] = strdup(list->word->word);
nargs = 0;
list = list->next;
// Second parameter must be the return type
if (decode_type_prefix(list->word->word,
NULL,
&rettype,
NULL,
NULL) != true) {
builtin_warning("couldnt parse the return type %s", list->word->word);
return EXECUTION_FAILURE;
}
// Skip past return type
list = list->next;
while (list) {
argtypes = realloc(argtypes, (nargs + 1) * sizeof(ffi_type *));
proto = realloc(proto, (nargs + 1 + 1) * sizeof(char *));
if (decode_type_prefix(list->word->word, NULL, &argtypes[nargs], NULL, &proto[nargs+1]) != true) {
builtin_error("failed to decode type from parameter %s", list->word->word);
goto error;
}
list = list->next;
nargs++;
}
if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rettype, argtypes) == FFI_OK) {
// Initialize the closure.
if (ffi_prep_closure_loc(closure, cif, execute_bash_trampoline, proto, callback) == FFI_OK) {
char retval[1024];
snprintf(retval, sizeof retval, "pointer:%p", callback);
fprintf(stderr, "%s\n", retval);
bind_variable(resultname, retval, 0);
}
}
//free(argtypes);
return 0;
error:
//free(argtypes);
return 1;
}
void call_foreign_function(Process *process, Obj *function, Obj **args, int arg_count) {
assert(function);
if(!function->funptr) {
eval_error = obj_new_string("Can't call foregin function, it's funptr is NULL. May be a stub function with just a signature?");
return;
}
assert(function->cif);
assert(function->arg_types);
assert(function->return_type);
// TODO: change name to 'arg_values' or something like that
void **values = calloc(sizeof(void*), arg_count);
assert(values);
#define assert_or_free_values_and_set_error(assertion, message, object) \
if(!(assertion)) { \
free(values); \
} \
assert_or_set_error((assertion), (message), (object));
Obj *p = function->arg_types;
for(int i = 0; i < arg_count; i++) {
if(p && p->cdr) {
assert(p->car);
Obj *type_obj = p->car;
// Handle ref types by unwrapping them: (:ref x) -> x
if(type_obj->tag == 'C' && type_obj->car && type_obj->cdr && type_obj->cdr->car && obj_eq(process, type_obj->car, type_ref)) {
type_obj = type_obj->cdr->car; // the second element of the list
}
args[i]->given_to_ffi = true; // This makes the GC ignore this value when deleting internal C-data, like inside a string
if(obj_eq(process, type_obj, type_int)) {
assert_or_free_values_and_set_error(args[i]->tag == 'I', "Invalid (expected int) type of arg: ", args[i]);
values[i] = &args[i]->i;
}
else if(obj_eq(process, type_obj, type_bool)) {
assert_or_free_values_and_set_error(args[i]->tag == 'B', "Invalid (expected bool) type of arg: ", args[i]);
bool b = args[i]->boolean;
values[i] = &b;
}
else if(obj_eq(process, type_obj, type_char)) {
assert_or_free_values_and_set_error(args[i]->tag == 'T', "Invalid (expected char) type of arg: ", args[i]);
char c = args[i]->character;
values[i] = &c;
}
else if(obj_eq(process, type_obj, type_float)) {
assert_or_free_values_and_set_error(args[i]->tag == 'V', "Invalid (expected float) type of arg: ", args[i]);
values[i] = &args[i]->f32;
}
else if(obj_eq(process, type_obj, type_double)) {
assert_or_free_values_and_set_error(args[i]->tag == 'W', "Invalid (expected double) type of arg: ", args[i]);
values[i] = &args[i]->f64;
}
else if(obj_eq(process, type_obj, type_string)) {
assert_or_free_values_and_set_error(args[i]->tag == 'S', "Invalid (expected string) type of arg: ", args[i]);
//args[i]->s = strdup(args[i]->s); // OBS! Duplicating string here. TODO: Think about if this is the correct thing to do!
values[i] = &args[i]->s;
}
else {
//printf("Calling function with expected parameter of type %s. Argument is of type %c.\n", obj_to_string(process, p->car)->s, args[i]->tag);
if(args[i]->tag == 'Q' /* || args[i]->tag == 'R' */) {
#ifdef CHECKING
if(args[i]->void_ptr == NULL || obj_eq(type_obj, obj_new_keyword("any"))) {
goto hack;
}
assert_or_free_values_and_set_error(args[i]->meta, "Argument is missing meta data: ", args[i]);
Obj *meta_type_tag = env_lookup(args[i]->meta, obj_new_keyword("type")); // TODO: make this keyword to a "singleton"
assert_or_free_values_and_set_error(meta_type_tag, "Argument is missing meta 'type' tag: ", args[i]);
bool eq = obj_eq(meta_type_tag, type_obj);
if(!eq) {
eval_error = obj_new_string("Invalid type of argument sent to function expecting '");
obj_string_mut_append(eval_error, obj_to_string(type_obj)->s);
obj_string_mut_append(eval_error, "' type: ");
obj_string_mut_append(eval_error, obj_to_string(meta_type_tag)->s);
return;
}
hack:;
#endif
values[i] = &args[i]->void_ptr;
}
else if(args[i]->tag == 'A') {
// TODO: Do some type checking here!!!
Array *a = obj_array_to_carp_array(process, args[i]);
if(eval_error) {
return;
}
assert(a);
values[i] = &a;
}
else if(args[i]->tag == 'F') {
values[i] = &args[i]->funptr;
}
else if(args[i]->tag == 'L') {
if(ALLOW_SENDING_LAMBDA_TO_FFI) {
//printf("Will call unbaked lambda from ffi function. Lambda should have types: %s\n", obj_to_string(type_obj)->s);
ffi_type *closure_args[1];
ffi_closure *closure;
void (*closure_fun_ptr)();
closure = ffi_closure_alloc(sizeof(ffi_closure), (void**)&closure_fun_ptr);
if (closure) {
/* Initialize the argument info vectors */
closure_args[0] = &ffi_type_pointer;
/* ffi_cif cif_static; */
/* ffi_cif *cif = &cif_static; */
/* ffi_prep_cif(cif, FFI_DEFAULT_ABI, 0, &ffi_type_void, closure_args); */
//printf("Type obj: %s\n", obj_to_string(type_obj)->s);
Obj *lambda_arg_types = type_obj->cdr->car;
Obj *lambda_return_type = type_obj->cdr->cdr->car;
int lambda_arg_count = 0;
Obj *p = lambda_arg_types;
while(p && p->car) {
p = p->cdr;
lambda_arg_count++;
}
ffi_cif *cif = create_cif(process, lambda_arg_types, lambda_arg_count, lambda_return_type, "TODO:proper-name");
Obj *lambda_arg = args[i];
LambdaAndItsType *lambda_and_its_type = malloc(sizeof(LambdaAndItsType)); // TODO: free!
lambda_and_its_type->lambda = lambda_arg; // the uncompiled lambda that was passed to the ffi function
lambda_and_its_type->signature = type_obj;
lambda_and_its_type->process = process;
typedef void (*LambdaCallback)(ffi_cif *, void *, void **, void *);
if (ffi_prep_closure_loc(closure, cif, (LambdaCallback)call_lambda_from_ffi, lambda_and_its_type, closure_fun_ptr) == FFI_OK) {
//printf("Closure preparation done.\n");
values[i] = &closure_fun_ptr;
}
else {
set_error("Closure prep failed. ", nil);
}
}
else {
set_error("Failed to allocate closure. ", nil);
}
} else {
free(values);
set_error("Can't send argument of lambda type (tag 'L') to ffi function, you need to compile it to a C function using (bake ...) first:\n", args[i]);
}
}
else {
free(values);
printf("INVALID ARG TYPE: %c\n", args[i]->tag);
printf("ARG: %s\n", obj_to_string(process, args[i])->s);
set_error("Can't send argument of invalid type to foreign function taking parameter of type ", p->car);
}
}
p = p->cdr;
}
else {
free(values);
set_error("Too many arguments to ", function);
}
}
if(p && p->car) {
free(values);
set_error("Too few arguments to ", function);
}
// Handle refs:
Obj *return_type = function->return_type;
if(return_type->tag == 'C' && return_type->car && return_type->cdr &&
return_type->cdr->car && obj_eq(process, return_type->car, type_ref)) {
return_type = return_type->cdr->car; // the second element of the list
}
void *result;
ffi_call(function->cif, function->funptr, &result, values);
Obj *obj_result = primitive_to_obj(process, result, return_type);
free(values);
if(!obj_result) {
printf("obj_result == NULL, return_type = %s\n", obj_to_string(process, return_type)->s);
return; // something went wrong
}
stack_push(process, obj_result);
}
callback*
create_callback(JNIEnv* env, jobject obj, jobject method,
jobjectArray param_types, jclass return_type,
callconv_t calling_convention, jboolean direct) {
callback* cb;
ffi_abi abi = FFI_DEFAULT_ABI;
ffi_abi java_abi = FFI_DEFAULT_ABI;
ffi_type* ffi_rtype;
ffi_status status;
jsize argc;
JavaVM* vm;
int rtype;
char msg[64];
int i;
int cvt = 0;
const char* throw_type = NULL;
const char* throw_msg = NULL;
if ((*env)->GetJavaVM(env, &vm) != JNI_OK) {
throwByName(env, EUnsatisfiedLink, "Can't get Java VM");
return NULL;
}
argc = (*env)->GetArrayLength(env, param_types);
cb = (callback *)malloc(sizeof(callback));
cb->closure = ffi_closure_alloc(sizeof(ffi_closure), &cb->x_closure);
cb->object = (*env)->NewWeakGlobalRef(env, obj);
cb->methodID = (*env)->FromReflectedMethod(env, method);
cb->vm = vm;
cb->arg_types = (ffi_type**)malloc(sizeof(ffi_type*) * argc);
cb->java_arg_types = (ffi_type**)malloc(sizeof(ffi_type*) * (argc + 3));
cb->arg_jtypes = (char*)malloc(sizeof(char) * argc);
cb->flags = (int *)malloc(sizeof(int) * argc);
cb->rflag = CVT_DEFAULT;
cb->arg_classes = (jobject*)malloc(sizeof(jobject) * argc);
cb->direct = direct;
cb->java_arg_types[0] = cb->java_arg_types[1] = cb->java_arg_types[2] = &ffi_type_pointer;
for (i=0;i < argc;i++) {
int jtype;
jclass cls = (*env)->GetObjectArrayElement(env, param_types, i);
if ((cb->flags[i] = get_conversion_flag(env, cls)) != CVT_DEFAULT) {
cb->arg_classes[i] = (*env)->NewWeakGlobalRef(env, cls);
cvt = 1;
}
jtype = get_jtype(env, cls);
if (jtype == -1) {
snprintf(msg, sizeof(msg), "Unsupported argument at index %d", i);
throw_type = EIllegalArgument;
throw_msg = msg;
goto failure_cleanup;
}
cb->arg_jtypes[i] = (char)jtype;
cb->java_arg_types[i+3] = cb->arg_types[i] = get_ffi_type(env, cls, cb->arg_jtypes[i]);
if (cb->flags[i] == CVT_NATIVE_MAPPED
|| cb->flags[i] == CVT_POINTER_TYPE
|| cb->flags[i] == CVT_INTEGER_TYPE) {
jclass ncls;
ncls = getNativeType(env, cls);
jtype = get_jtype(env, ncls);
if (jtype == -1) {
snprintf(msg, sizeof(msg), "Unsupported NativeMapped argument native type at argument %d", i);
throw_type = EIllegalArgument;
throw_msg = msg;
goto failure_cleanup;
}
cb->arg_jtypes[i] = (char)jtype;
cb->java_arg_types[i+3] = &ffi_type_pointer;
cb->arg_types[i] = get_ffi_type(env, ncls, cb->arg_jtypes[i]);
}
if (cb->arg_types[i]->type == FFI_TYPE_FLOAT) {
// Java method is varargs, so promote floats to double
cb->java_arg_types[i+3] = &ffi_type_double;
cb->flags[i] = CVT_FLOAT;
cvt = 1;
}
else if (cb->java_arg_types[i+3]->type == FFI_TYPE_STRUCT) {
// All callback structure arguments are passed as a jobject
cb->java_arg_types[i+3] = &ffi_type_pointer;
}
}
if (!direct || !cvt) {
free(cb->flags);
cb->flags = NULL;
free(cb->arg_classes);
cb->arg_classes = NULL;
}
if (direct) {
cb->rflag = get_conversion_flag(env, return_type);
if (cb->rflag == CVT_NATIVE_MAPPED
|| cb->rflag == CVT_INTEGER_TYPE
|| cb->rflag == CVT_POINTER_TYPE) {
return_type = getNativeType(env, return_type);
}
}
#if defined(_WIN32) && !defined(_WIN64)
if (calling_convention == CALLCONV_STDCALL) {
abi = FFI_STDCALL;
}
java_abi = FFI_STDCALL;
#endif // _WIN32
rtype = get_jtype(env, return_type);
if (rtype == -1) {
throw_type = EIllegalArgument;
throw_msg = "Unsupported return type";
goto failure_cleanup;
}
ffi_rtype = get_ffi_rtype(env, return_type, (char)rtype);
if (!ffi_rtype) {
throw_type = EIllegalArgument;
throw_msg = "Error in return type";
goto failure_cleanup;
}
status = ffi_prep_cif(&cb->cif, abi, argc, ffi_rtype, cb->arg_types);
if (!ffi_error(env, "callback setup", status)) {
ffi_type* java_ffi_rtype = ffi_rtype;
if (cb->rflag == CVT_STRUCTURE_BYVAL
|| cb->rflag == CVT_NATIVE_MAPPED
|| cb->rflag == CVT_POINTER_TYPE
|| cb->rflag == CVT_INTEGER_TYPE) {
// Java method returns a jobject, not a struct
java_ffi_rtype = &ffi_type_pointer;
rtype = '*';
}
switch(rtype) {
case 'V': cb->fptr = (*env)->CallVoidMethod; break;
case 'Z': cb->fptr = (*env)->CallBooleanMethod; break;
case 'B': cb->fptr = (*env)->CallByteMethod; break;
case 'S': cb->fptr = (*env)->CallShortMethod; break;
case 'C': cb->fptr = (*env)->CallCharMethod; break;
case 'I': cb->fptr = (*env)->CallIntMethod; break;
case 'J': cb->fptr = (*env)->CallLongMethod; break;
case 'F': cb->fptr = (*env)->CallFloatMethod; break;
case 'D': cb->fptr = (*env)->CallDoubleMethod; break;
default: cb->fptr = (*env)->CallObjectMethod; break;
}
status = ffi_prep_cif(&cb->java_cif, java_abi, argc+3, java_ffi_rtype, cb->java_arg_types);
if (!ffi_error(env, "callback setup (2)", status)) {
ffi_prep_closure_loc(cb->closure, &cb->cif, callback_dispatch, cb,
cb->x_closure);
return cb;
}
}
failure_cleanup:
free_callback(env, cb);
if (throw_type) {
throwByName(env, throw_type, msg);
}
return NULL;
}
Handle poly_ffi(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, code->Word());
switch (c)
{
case 0: // malloc
{
POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word());
return toSysWord(taskData, malloc(size));
}
case 1: // free
{
void *mem = *(void**)(args->WordP());
free(mem);
return taskData->saveVec.push(TAGGED(0));
}
case 2: // Load library
{
TempString libName(args->Word());
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HINSTANCE lib = LoadLibrary(libName);
if (lib == NULL)
{
char buf[256];
#if (defined(UNICODE))
_snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", libName, GetLastError());
#else
_snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", libName, GetLastError());
#endif
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = dlopen(libName, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char *)libName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 3: // Load address of executable.
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HINSTANCE lib = hApplicationInstance;
#else
void *lib = dlopen(NULL, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 4: // Unload library - Is this actually going to be used?
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HMODULE hMod = *(HMODULE*)(args->WordP());
if (! FreeLibrary(hMod))
raise_syscall(taskData, "FreeLibrary failed", -(int)GetLastError());
#else
void *lib = *(void**)(args->WordP());
if (dlclose(lib) != 0)
{
char buf[256];
snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return taskData->saveVec.push(TAGGED(0));
}
case 5: // Load the address of a symbol from a library.
{
TempCString symName(args->WordP()->Get(1));
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress());
void *sym = (void*)GetProcAddress(hMod, symName);
if (sym == NULL)
{
char buf[256];
_snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", symName, GetLastError());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = *(void**)(args->WordP()->Get(0).AsAddress());
void *sym = dlsym(lib, symName);
if (sym == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char *)symName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, sym);
}
// Libffi functions
case 50: // Return a list of available ABIs
return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]),
(char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab);
case 51: // A constant from the table
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(constantTable) / sizeof(constantTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return Make_arbitrary_precision(taskData, constantTable[index]);
}
case 52: // Return an FFI type
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return toSysWord(taskData, ffiTypeTable[index]);
}
case 53: // Extract fields from ffi type.
{
ffi_type *ffit = *(ffi_type**)(args->WordP());
Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size);
Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment);
Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type);
Handle elemHandle = toSysWord(taskData, ffit->elements);
Handle resHandle = alloc_and_save(taskData, 4);
resHandle->WordP()->Set(0, sizeHandle->Word());
resHandle->WordP()->Set(1, alignHandle->Word());
resHandle->WordP()->Set(2, typeHandle->Word());
resHandle->WordP()->Set(3, elemHandle->Word());
return resHandle;
}
case 54: // Construct an ffi type.
{
// This is probably only used to create structs.
size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0));
unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1));
unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2));
unsigned nElems = 0;
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nElems++;
size_t space = sizeof(ffi_type);
// If we need the elements add space for the elements plus
// one extra for the zero terminator.
if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *);
ffi_type *result = (ffi_type*)malloc(space);
// Raise an exception rather than returning zero.
if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **elem = 0;
if (nElems != 0) elem = (ffi_type **)(result+1);
memset(result, 0, sizeof(ffi_type)); // Zero it in case they add fields
result->size = size;
result->alignment = align;
result->type = type;
result->elements = elem;
if (elem != 0)
{
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*elem++ = *(ffi_type**)(e.AsAddress());
}
*elem = 0;
}
return toSysWord(taskData, result);
}
case 55: // Create a CIF. This contains all the types and some extra information.
// The result is in allocated memory followed immediately by the argument type vector.
{
ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0));
ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress();
unsigned nArgs = 0;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nArgs++;
// Allocate space for the cif followed by the argument type vector
size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*);
ffi_cif *cif = (ffi_cif *)malloc(space);
if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **atypes = (ffi_type **)(cif+1);
// Copy the arguments types.
ffi_type **at = atypes;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*at++ = *(ffi_type**)(e.AsAddress());
}
ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes);
if (status == FFI_BAD_TYPEDEF)
raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif");
else if (status == FFI_BAD_ABI)
raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif");
else if (status != FFI_OK)
raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif");
return toSysWord(taskData, cif);
}
case 56: // Call a function.
{
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress();
void *f = *(void**)args->WordP()->Get(1).AsAddress();
void *res = *(void**)args->WordP()->Get(2).AsAddress();
void **arg = *(void***)args->WordP()->Get(3).AsAddress();
// We release the ML memory across the call so a GC can occur
// even if this thread is blocked in the C code.
processes->ThreadReleaseMLMemory(taskData);
ffi_call(cif, FFI_FN(f), res, arg);
processes->ThreadUseMLMemory(taskData);
return taskData->saveVec.push(TAGGED(0));
}
case 57: // Create a callback.
{
#ifdef INTERPRETED
raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter");
#endif
Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0));
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress();
void *resultFunction;
// Allocate the memory. resultFunction is set to the executable address in or related to
// the memory.
ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction);
if (closure == 0)
raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory");
PLocker pLocker(&callbackTableLock);
// Find a free entry in the table if there is one.
unsigned entryNo = 0;
while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++;
if (entryNo == callBackEntries)
{
// Need to grow the table.
struct _cbStructEntry *newTable =
(struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry));
if (newTable == 0)
raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table");
callbackTable = newTable;
callBackEntries++;
}
callbackTable[entryNo].mlFunction = mlFunction->Word();
callbackTable[entryNo].closureSpace = closure;
callbackTable[entryNo].resultFunction = resultFunction;
if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK)
raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed");
return toSysWord(taskData, resultFunction);
}
case 58: // Free an existing callback.
{
// The address returned from call 57 above is the executable address that can
// be passed as a callback function. The writable memory address returned
// as the result of ffi_closure_alloc may or may not be the same. To be safe
// we need to search the table.
void *resFun = *(void**)args->Word().AsAddress();
PLocker pLocker(&callbackTableLock);
unsigned i = 0;
while (i < callBackEntries)
{
if (callbackTable[i].resultFunction == resFun)
{
ffi_closure_free(callbackTable[i].closureSpace);
callbackTable[i].closureSpace = 0;
callbackTable[i].resultFunction = 0;
callbackTable[i].mlFunction = TAGGED(0); // Release the ML function
return taskData->saveVec.push(TAGGED(0));
}
}
raise_exception_string(taskData, EXC_foreign, "Invalid callback entry");
}
default:
{
char msg[100];
sprintf(msg, "Unknown ffi function: %d", c);
raise_exception_string(taskData, EXC_foreign, msg);
return 0;
}
}
}
callback*
create_callback(JNIEnv* env, jobject obj, jobject method,
jobjectArray arg_classes, jclass return_class,
callconv_t calling_convention,
jint options,
jstring encoding) {
jboolean direct = options & CB_OPTION_DIRECT;
jboolean in_dll = options & CB_OPTION_IN_DLL;
callback* cb;
ffi_abi abi = (calling_convention == CALLCONV_C
? FFI_DEFAULT_ABI : (ffi_abi)calling_convention);
ffi_abi java_abi = FFI_DEFAULT_ABI;
ffi_type* return_type;
ffi_status status;
jsize argc;
JavaVM* vm;
int rtype;
char msg[MSG_SIZE];
int i;
int cvt = 0;
const char* throw_type = NULL;
const char* throw_msg = NULL;
if ((*env)->GetJavaVM(env, &vm) != JNI_OK) {
throwByName(env, EUnsatisfiedLink, "Couldn't obtain Java VM reference when creating native callback");
return NULL;
}
argc = (*env)->GetArrayLength(env, arg_classes);
cb = (callback *)malloc(sizeof(callback));
cb->closure = ffi_closure_alloc(sizeof(ffi_closure), &cb->x_closure);
cb->saved_x_closure = cb->x_closure;
cb->object = (*env)->NewWeakGlobalRef(env, obj);
cb->methodID = (*env)->FromReflectedMethod(env, method);
cb->vm = vm;
cb->arg_types = (ffi_type**)malloc(sizeof(ffi_type*) * argc);
cb->java_arg_types = (ffi_type**)malloc(sizeof(ffi_type*) * (argc + 3));
cb->arg_jtypes = (char*)malloc(sizeof(char) * argc);
cb->conversion_flags = (int *)malloc(sizeof(int) * argc);
cb->rflag = CVT_DEFAULT;
cb->arg_classes = (jobject*)malloc(sizeof(jobject) * argc);
cb->direct = direct;
cb->java_arg_types[0] = cb->java_arg_types[1] = cb->java_arg_types[2] = &ffi_type_pointer;
cb->encoding = newCStringUTF8(env, encoding);
for (i=0;i < argc;i++) {
int jtype;
jclass cls = (*env)->GetObjectArrayElement(env, arg_classes, i);
if ((cb->conversion_flags[i] = get_conversion_flag(env, cls)) != CVT_DEFAULT) {
cb->arg_classes[i] = (*env)->NewWeakGlobalRef(env, cls);
cvt = 1;
}
else {
cb->arg_classes[i] = NULL;
}
jtype = get_java_type(env, cls);
if (jtype == -1) {
snprintf(msg, sizeof(msg), "Unsupported callback argument at index %d", i);
throw_type = EIllegalArgument;
throw_msg = msg;
goto failure_cleanup;
}
cb->arg_jtypes[i] = (char)jtype;
cb->java_arg_types[i+3] = cb->arg_types[i] = get_ffi_type(env, cls, cb->arg_jtypes[i]);
if (!cb->java_arg_types[i+3]) {
goto failure_cleanup;
}
if (cb->conversion_flags[i] == CVT_NATIVE_MAPPED
|| cb->conversion_flags[i] == CVT_POINTER_TYPE
|| cb->conversion_flags[i] == CVT_INTEGER_TYPE) {
jclass ncls;
ncls = getNativeType(env, cls);
jtype = get_java_type(env, ncls);
if (jtype == -1) {
snprintf(msg, sizeof(msg), "Unsupported NativeMapped callback argument native type at argument %d", i);
throw_type = EIllegalArgument;
throw_msg = msg;
goto failure_cleanup;
}
cb->arg_jtypes[i] = (char)jtype;
cb->java_arg_types[i+3] = &ffi_type_pointer;
cb->arg_types[i] = get_ffi_type(env, ncls, cb->arg_jtypes[i]);
if (!cb->arg_types[i]) {
goto failure_cleanup;
}
}
// Java callback method is called using varargs, so promote floats to
// double where appropriate for the platform
if (cb->arg_types[i]->type == FFI_TYPE_FLOAT) {
cb->java_arg_types[i+3] = &ffi_type_double;
cb->conversion_flags[i] = CVT_FLOAT;
cvt = 1;
}
else if (cb->java_arg_types[i+3]->type == FFI_TYPE_STRUCT) {
// All callback structure arguments are passed as a jobject
cb->java_arg_types[i+3] = &ffi_type_pointer;
}
}
if (!direct || !cvt) {
free(cb->conversion_flags);
cb->conversion_flags = NULL;
free(cb->arg_classes);
cb->arg_classes = NULL;
}
if (direct) {
cb->rflag = get_conversion_flag(env, return_class);
if (cb->rflag == CVT_NATIVE_MAPPED
|| cb->rflag == CVT_INTEGER_TYPE
|| cb->rflag == CVT_POINTER_TYPE) {
return_class = getNativeType(env, return_class);
}
}
#if defined(_WIN32)
if (calling_convention == CALLCONV_STDCALL) {
#if defined(_WIN64) || defined(_WIN32_WCE)
// Ignore requests for stdcall on win64/wince
abi = FFI_DEFAULT_ABI;
#else
abi = FFI_STDCALL;
// All JNI entry points on win32 use stdcall
java_abi = FFI_STDCALL;
#endif
}
#endif // _WIN32
if (!(abi > FFI_FIRST_ABI && abi < FFI_LAST_ABI)) {
snprintf(msg, sizeof(msg), "Invalid calling convention %d", abi);
throw_type = EIllegalArgument;
throw_msg = msg;
goto failure_cleanup;
}
rtype = get_java_type(env, return_class);
if (rtype == -1) {
throw_type = EIllegalArgument;
throw_msg = "Unsupported callback return type";
goto failure_cleanup;
}
return_type = get_ffi_return_type(env, return_class, (char)rtype);
if (!return_type) {
throw_type = EIllegalArgument;
throw_msg = "Error in callback return type";
goto failure_cleanup;
}
status = ffi_prep_cif(&cb->cif, abi, argc, return_type, cb->arg_types);
if (!ffi_error(env, "callback setup", status)) {
ffi_type* java_return_type = return_type;
if (cb->rflag == CVT_STRUCTURE_BYVAL
|| cb->rflag == CVT_NATIVE_MAPPED
|| cb->rflag == CVT_POINTER_TYPE
|| cb->rflag == CVT_INTEGER_TYPE) {
// Java method returns a jobject, not a struct
java_return_type = &ffi_type_pointer;
rtype = '*';
}
switch(rtype) {
#define OFFSETOF(ENV,METHOD) ((size_t)((char *)&(*(ENV))->METHOD - (char *)(*(ENV))))
case 'V': cb->fptr_offset = OFFSETOF(env, CallVoidMethod); break;
case 'Z': cb->fptr_offset = OFFSETOF(env, CallBooleanMethod); break;
case 'B': cb->fptr_offset = OFFSETOF(env, CallByteMethod); break;
case 'S': cb->fptr_offset = OFFSETOF(env, CallShortMethod); break;
case 'C': cb->fptr_offset = OFFSETOF(env, CallCharMethod); break;
case 'I': cb->fptr_offset = OFFSETOF(env, CallIntMethod); break;
case 'J': cb->fptr_offset = OFFSETOF(env, CallLongMethod); break;
case 'F': cb->fptr_offset = OFFSETOF(env, CallFloatMethod); break;
case 'D': cb->fptr_offset = OFFSETOF(env, CallDoubleMethod); break;
default: cb->fptr_offset = OFFSETOF(env, CallObjectMethod); break;
}
status = ffi_prep_cif_var(&cb->java_cif, java_abi, 2, argc+3, java_return_type, cb->java_arg_types);
if (!ffi_error(env, "callback setup (2)", status)) {
ffi_prep_closure_loc(cb->closure, &cb->cif, dispatch_callback, cb,
cb->x_closure);
#ifdef DLL_FPTRS
// Find an available function pointer and assign it
if (in_dll) {
for (i=0;i < DLL_FPTRS;i++) {
if (fn[i] == NULL) {
fn[i] = cb->x_closure;
cb->x_closure = dll_fptrs[i];
break;
}
}
if (i == DLL_FPTRS) {
throw_type = EOutOfMemory;
throw_msg = "No more DLL callback slots available";
goto failure_cleanup;
}
}
#endif
return cb;
}
}
failure_cleanup:
free_callback(env, cb);
if (throw_type) {
throwByName(env, throw_type, throw_msg);
}
return NULL;
}
cl_object si::make-dynamic-callback(cl_narg narg, ...)
{
#line 989
// ------------------------------2
#line 989
const cl_env_ptr the_env = ecl_process_env();
#line 989
cl_object cc_type;
#line 989
va_list ARGS;
va_start(ARGS, narg);
cl_object fun = va_arg(ARGS,cl_object);
cl_object sym = va_arg(ARGS,cl_object);
cl_object return_type = va_arg(ARGS,cl_object);
cl_object arg_types = va_arg(ARGS,cl_object);
#line 989
// ------------------------------3
#line 991
// ------------------------------4
#line 991
#line 991
if (ecl_unlikely(narg < 4|| narg > 5)) FEwrong_num_arguments(ecl_make_fixnum(1591));
#line 991
if (narg > 4) {
#line 991
cc_type = va_arg(ARGS,cl_object);
#line 991
} else {
#line 991
cc_type = ECL_SYM(":DEFAULT",1215);
#line 991
}
#line 991
// ------------------------------5
{
ffi_cif *cif = ecl_alloc(sizeof(ffi_cif));
ffi_type **types;
int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type,
&types);
/* libffi allocates executable memory for us. ffi_closure_alloc()
* returns a pointer to memory and a pointer to the beginning of
* the actual executable region (executable_closure) which is
* where the code resides. */
void *executable_region;
ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region);
cl_object closure_object = ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377),
sizeof(ffi_closure),
closure);
si_set_finalizer(closure_object, ECL_SYM("SI::FREE-FFI-CLOSURE",1592));
cl_object data = cl_list(6, closure_object,
fun, return_type, arg_types, cc_type,
ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377),
sizeof(*cif), cif),
ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377),
(n + 1) * sizeof(ffi_type*),
types));
int status = ffi_prep_closure_loc(closure, cif, callback_executor,
ECL_CONS_CDR(data), executable_region);
if (status != FFI_OK) {
FEerror("Unable to build callback. libffi returns ~D", 1,
ecl_make_fixnum(status));
}
si_put_sysprop(sym, ECL_SYM(":CALLBACK",1590), data);
{
#line 1024
#line 1024
cl_object __value0 = closure_object;
#line 1024
the_env->nvalues = 1;
#line 1024
return __value0;
#line 1024
}
;
}
}
