2 * effi.c --- Foreign Function Interface for SXEmacs.
4 * Copyright (C) 2004-2008 Zajcev Evgeny
6 This file is part of SXEmacs
8 SXEmacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 SXEmacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
32 # include "mule/file-coding.h"
38 #endif /* HAVE_LIBFFI */
41 # include "events/workers.h"
42 # include "events/worker-asyneq.h"
43 #endif /* EF_USE_ASYNEQ */
45 /* For `x-device-display' */
46 #include "ui/X11/console-x.h"
47 #include "ui/device.h"
49 #define EFFI_CODING Qnative
52 * Some compatibility for XEmacs
55 # define SIGNAL_ERROR signal_error
56 # define FFIBYTE Bufbyte
57 # define WRITE_C_STRING(x,y) write_c_string((x),(y))
58 # define WRITE_FMT_STRING(x,y,...) write_fmt_string((x),(y),__VA_ARGS__)
59 # define LRECORD_DESCRIPTION lrecord_description
61 # define SIGNAL_ERROR Fsignal
62 # define FFIBYTE Ibyte
63 # define WRITE_C_STRING(x,y) write_c_string((y),(x))
64 # define WRITE_FMT_STRING(x,y,...) \
67 int wcss = snprintf(wcsb, sizeof(wcsb), \
69 write_c_string((y),wcsb); \
71 # define LRECORD_DESCRIPTION memory_description
76 * byte, ubyte, char, uchar,
77 * short, ushort, int, uint,
80 * void, pointer, c-string
84 * (function RET-TYPE IN-TYPE .. IN-TYPE)
90 * Structures and unions types:
100 * pointer or (pointer TYPE)
104 Lisp_Object Q_byte, Q_unsigned_byte;
105 Lisp_Object Q_char, Q_unsigned_char;
106 Lisp_Object Q_short, Q_unsigned_short;
107 Lisp_Object Q_int, Q_unsigned_int;
108 Lisp_Object Q_long, Q_unsigned_long;
109 Lisp_Object Q_float, Q_double;
111 Lisp_Object Q_array, Q_pointer;
112 Lisp_Object Q_union, Q_struct;
113 Lisp_Object Q_function;
114 Lisp_Object Q_c_string, Q_c_data;
116 #define FFI_POINTERP(type) (EQ(type, Q_pointer) \
117 || (CONSP(type) && EQ(XCAR(type), Q_pointer)))
119 #define FFI_TPTR(type) (EQ(type, Q_c_string) \
120 || EQ(type, Q_c_data) \
121 || FFI_POINTERP(type) \
122 || (CONSP(type) && ((EQ(XCAR(type), Q_c_data)) \
123 || EQ(XCAR(type), Q_array))))
125 Lisp_Object Qffiobjectp;
126 Lisp_Object Qffi_translate_to_foreign;
127 Lisp_Object Qffi_translate_from_foreign;
129 /* Alist with elements in form (NAME . TYPE) */
130 Lisp_Object Vffi_loaded_libraries;
131 Lisp_Object Vffi_named_types;
133 Lisp_Object Vffi_type_checker;
135 static Lisp_Object Vffi_all_objects;
137 Lisp_Object Q_ffi_callback;
140 mark_ffiobject(Lisp_Object obj)
142 Lisp_EffiObject *ffio = XEFFIO(obj);
143 mark_object(ffio->type);
144 mark_object(ffio->size);
145 mark_object(ffio->plist);
146 return (ffio->plist);
150 print_ffiobject(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
152 /* This function can GC */
153 Lisp_EffiObject *ffio = XEFFIO(obj);
154 escapeflag = escapeflag; /* shutup compiler */
155 if (print_readably) {
157 error("printing unreadable object #<ffiobject 0x%x>",
160 signal_ferror(Qinternal_error,
161 "printing unreadable object #<ffiobject 0x%x>",
165 WRITE_C_STRING("#<ffiobject ", printcharfun);
166 /* Print FFIO type */
167 if (!NILP(ffio->type)) {
168 WRITE_C_STRING("type=", printcharfun);
169 print_internal(ffio->type, printcharfun, 1);
170 WRITE_C_STRING(" ", printcharfun);
172 WRITE_FMT_STRING(printcharfun,"size=%ld fotype=%d foptr=%p>",
173 (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
176 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
177 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
178 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
179 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
180 {XD_INT, offsetof(Lisp_EffiObject, fotype)},
181 {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
183 {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
185 {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
191 ffi_getprop(Lisp_Object fo, Lisp_Object property)
193 return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
197 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
199 external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
204 ffi_remprop(Lisp_Object fo, Lisp_Object property)
206 return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
211 sizeof_ffiobject(const void *header)
213 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
214 return (sizeof(Lisp_EffiObject) + effio->storage_size);
218 sizeof_ffiobject(const void *header)
220 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
221 return (sizeof(Lisp_EffiObject) + effio->storage_size);
225 /* Define ffiobject implementation */
226 const struct lrecord_implementation lrecord_ffiobject = {
228 .marker = mark_ffiobject,
229 .printer = print_ffiobject,
233 .description = ffiobject_description,
234 .getprop = ffi_getprop,
235 .putprop = ffi_putprop,
236 .remprop = ffi_remprop,
239 .size_in_bytes_method = sizeof_ffiobject,
240 .lrecord_type_index = lrecord_type_ffiobject,
245 /** alignment in union and structures **/
249 * - An entire structure or union is aligned on the same boundary as
250 * its most strictly aligned member.
252 * - Each member is assigned to the lowest available offset with the
253 * appropriate alignment. This may require /internal padding/,
254 * depending on the previous member.
256 * - A structure's size is increased, if necessary, to make it a
257 * multiple of the alignment. This may require /tail padding/,
258 * depending on the last member.
263 * char c; .-------2+---1+---0.
264 * short s; | s |pad | c |
265 * } `--------+----+----'
267 * Internal and Tail padding:
269 * struct { .------------1+---0.
270 * char c; | pad | c |
271 * double d; |-------------+---4|
273 * } |-----------------8|
275 * |------14+-------12|
277 * `--------+---------'
281 * union { .------------1+---0.
282 * char c; | pad | c |
283 * short s; |-------2+----+---0|
285 * } |--------+--------0|
287 * `------------------'
290 ffi_check_type(Lisp_Object type)
292 return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
295 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
296 Return non-nil if TYPE is a basic FFI type.
298 A type is said to be basic, if it is neither a pointer nor a
299 function, and there is a corresponding built-in type in C.
303 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte) || EQ(type, Q_char)
304 || EQ(type, Q_unsigned_char) || EQ(type, Q_short)
305 || EQ(type, Q_unsigned_short) || EQ(type, Q_int)
306 || EQ(type, Q_unsigned_int) || EQ(type, Q_long)
307 || EQ(type, Q_unsigned_long) || EQ(type, Q_float)
308 || EQ(type, Q_double) || EQ(type, Q_void)
309 || EQ(type, Q_c_string) || EQ(type, Q_c_data)
310 || (CONSP(type) && EQ(XCAR(type), Q_c_data)))
318 ffi_canonicalise_type(Lisp_Object type)
320 /* this function canNOT GC */
322 while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
323 if EQ(type, Q_pointer)
325 type = Fcdr(Fassq(type, Vffi_named_types));
331 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
332 Return FFI type TYPE in a canonical form.
336 Lisp_Object canon_type = ffi_canonicalise_type(type);
337 if (NILP(canon_type)) {
339 signal_simple_error("No such FFI type", type);
341 signal_error(Qinternal_error, "No such FFI type", type);
347 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0, /*
348 Return the size of the foreign type TYPE.
350 Valid foreign types are: `byte', `unsigned-byte', `char',
351 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
352 `long', `unsigned-long', `pointer', `float', `double',
353 `object', and `c-string'.
359 type = ffi_canonicalise_type(type);
360 if (EQ(type, Q_void))
362 else if (EQ(type, Q_byte))
363 tsize = sizeof(int8_t);
364 else if (EQ(type, Q_unsigned_byte))
365 tsize = sizeof(uint8_t);
366 else if (EQ(type, Q_char))
367 tsize = sizeof(char);
368 else if (EQ(type, Q_unsigned_char))
369 tsize = sizeof(unsigned char);
370 else if (EQ(type, Q_short))
371 tsize = sizeof(short);
372 else if (EQ(type, Q_unsigned_short))
373 tsize = sizeof(unsigned short);
374 else if (EQ(type, Q_int))
376 else if (EQ(type, Q_unsigned_int))
377 tsize = sizeof(unsigned int);
378 else if (EQ(type, Q_long))
379 tsize = sizeof(long);
380 else if (EQ(type, Q_unsigned_long))
381 tsize = sizeof(unsigned long);
382 else if (EQ(type, Q_float))
383 tsize = sizeof(float);
384 else if (EQ(type, Q_double))
385 tsize = sizeof(double);
386 else if (EQ(type, Q_c_string))
387 tsize = sizeof(char *);
388 else if (FFI_POINTERP(type))
389 tsize = sizeof(void *);
390 else if (EQ(type, Q_c_data))
391 tsize = sizeof(void *);
392 else if (CONSP(type) && EQ(XCAR(type), Q_c_data)) {
393 Lisp_Object cdsize = XCDR(type);
395 tsize = XINT(cdsize);
396 } else if (CONSP(type) && EQ(XCAR(type), Q_function))
397 tsize = sizeof(void(*));
398 else if (CONSP(type) && EQ(XCAR(type), Q_array)) {
399 Lisp_Object atype = Fcar(XCDR(type));
400 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
403 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
404 } else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
405 return Fffi_slot_offset(type, Qnil);
406 } else if (CONSP(type) && EQ(XCAR(type), Q_union)) {
407 Lisp_Object slots = Fcdr(XCDR(type));
412 while (!NILP(slots)) {
413 Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
414 int slot_size = XINT(Fffi_size_of_type(slot_type));
415 if (slot_size > tsize)
421 signal_simple_error("Unrecognized foreign type", type);
423 signal_error(Qinternal_error, "Unrecognized foreign type", type);
427 return make_int(tsize);
430 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
431 Create a new FFI object of type TYPE.
432 If optional argument SIZE is non-nil it should be an
433 integer, in this case additional storage size to hold data
434 of at least length SIZE is allocated.
440 Lisp_Object result = Qnil;
441 Lisp_EffiObject *ffio;
446 /* NOTE: ffi_check_type returns canonical type */
447 ctype = ffi_check_type(type);
449 size = Fffi_size_of_type(type);
452 if (CONSP(ctype) && EQ(XCAR(ctype), Q_c_data) && INTP(XCDR(ctype)))
455 cs_or_cd = EQ(ctype, Q_c_string) || (EQ(ctype, Q_c_data));
456 if ((cs_or_cd && (XINT(size) < 1))
457 || (!(cs_or_cd || FFI_POINTERP(ctype))
458 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
460 signal_simple_error("storage size too small to store type",
463 ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
465 XSETEFFIO(result, ffio);
467 signal_error(Qinternal_error,
468 "storage size too small to store type",
471 ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
473 result = wrap_effio(ffio);
476 ffio->size = Fffi_size_of_type(type);
480 /* Initialize foreign pointer */
481 ffio->fotype = EFFI_FOT_NONE;
482 ffio->storage_size = XINT(size);
483 ffio->fop.ptr = ffio->fostorage;
485 if (!NILP(Vffi_all_objects))
486 XWEAK_LIST_LIST(Vffi_all_objects) =
487 Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
489 RETURN_UNGCPRO(result);
492 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
493 Return non-nil if FO is an FFI object, nil otherwise.
497 return (EFFIOP(fo) ? Qt : Qnil);
500 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
501 Return the address FO points to.
506 return make_float((long)XEFFIO(fo)->fop.ptr);
509 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
510 "Return a pointer pointing to ADDRESS."
518 addr = XINT(address);
519 else if (FLOATP(address))
520 addr = XFLOATINT(address);
523 signal_simple_error("FFI: invalid address type", address);
525 signal_error(Qinternal_error, "FFI: invalid address type",
530 ptr = Fmake_ffi_object(Q_pointer, Qnil);
531 XEFFIO(ptr)->fop.ptr = (void*)addr;
535 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
536 Return FO's real type, that is after resolving user defined types.
541 return ffi_canonicalise_type(XEFFIO(fo)->type);
544 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
550 return (XEFFIO(fo)->type);
553 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
554 Cast FO to type TYPE and reassign the cast value.
560 ffi_check_type(type);
561 XEFFIO(fo)->type = type;
566 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
567 Return the size of the allocated space of FO.
572 return (XEFFIO(fo)->size);
575 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
576 Set the size of the allocated space of FO.
582 XEFFIO(fo)->storage_size = XUINT(size);
586 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
587 Load library LIBNAME and return a foreign object handle if successful,
588 or `nil' if the library cannot be loaded.
590 The argument LIBNAME should be the file-name string of a shared object
591 library. Normally you should omit the file extension, as this
592 function will add the appripriate extension for the current platform
595 The library should reside in one of the directories specified by the
596 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
601 #ifdef LTDL_SHLIB_EXT
602 # define EXT LTDL_SHLIB_EXT
603 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
604 # define EXT ".dylib"
607 #endif /* LTDL_SHLIB_EXT */
609 void *handler, *dotpos;
610 Lisp_Object fo = Qnil;
611 Lisp_EffiObject *ffio;
615 CHECK_STRING(libname);
617 /* Add an extension if we need to */
618 dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
619 if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
620 ssize_t liblen = XSTRING_LENGTH(libname);
621 ssize_t soname_len = liblen + sizeof(EXT);
622 soname = xmalloc( soname_len + 1);
623 strncpy(soname, (char *)XSTRING_DATA(libname), liblen+1);
624 strncat(soname, EXT, sizeof(EXT)+1);
627 if ( soname == NULL ) {
628 handler = dlopen((const char *)XSTRING_DATA(libname),
629 RTLD_GLOBAL|RTLD_NOW);
631 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
639 fo = Fmake_ffi_object(Q_pointer, Qnil);
642 ffio->fotype = EFFI_FOT_BIND;
643 ffio->fop.ptr = handler;
648 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
649 Make and return a foreign object of type TYPE and bind it to the
652 The argument TYPE can be any type-cell.
653 The argument SYM should be a string naming an arbitrary symbol
654 in one of the loaded libraries.
656 If SYM does not exist in any of the loaded libraries, `nil' is
661 Lisp_Object fo = Qnil;
662 Lisp_EffiObject *ffio;
665 ffi_check_type(type);
669 fo = Fmake_ffi_object(type, Qnil);
671 ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
672 if (ffio->fop.ptr == NULL) {
677 ffio->fotype = EFFI_FOT_BIND;
682 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
683 Return dl error string.
687 const char *dles = dlerror();
689 if (LIKELY(dles != NULL)) {
690 size_t sz = strlen(dles);
691 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
697 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
698 Make and return a foreign object of type TYPE and bind it to the
701 The argument TYPE should be a function type-cell.
702 The argument SYM should be a string naming a function in one of
703 the loaded libraries.
705 If SYM does not exist in any of the loaded libraries, an error
708 This is like `ffi-bind' but for function objects.
712 Lisp_Object fo = Qnil;
713 Lisp_EffiObject *ffio;
716 ffi_check_type(type);
721 fo = Fmake_ffi_object(type, Qnil);
723 ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
724 if (ffio->fop.fun == NULL) {
726 signal_simple_error("Can't define function", sym);
728 signal_error(Qinternal_error, "Can't define function", sym);
732 ffio->fotype = EFFI_FOT_FUNC;
738 * Return alignment policy for struct or union FFI_SU.
739 * x86: Return 1, 2 or 4.
740 * mips: Return 1, 2, 4 or 8.
743 ffi_type_align(Lisp_Object type)
745 type = ffi_canonicalise_type(type);
747 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte)
748 || EQ(type, Q_char) || EQ(type, Q_unsigned_char))
750 if (EQ(type, Q_short) || EQ(type, Q_unsigned_short))
753 if (EQ(type, Q_double))
755 #endif /* FFI_MIPS */
758 } else if (CONSP(type)
759 && (EQ(XCAR(type), Q_struct) || EQ(XCAR(type), Q_union))) {
762 for (al = 0, type = Fcdr(Fcdr(type));
766 Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
767 int tmp_al = ffi_type_align(stype);
779 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
780 Return TYPE alignment.
784 return make_int(ffi_type_align(type));
787 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
788 Return the offset of SLOT in TYPE.
789 SLOT can be either a valid (named) slot in TYPE or `nil'.
790 If SLOT is `nil' return the size of the struct.
795 int lpad, align, retoff;
797 type = ffi_canonicalise_type(type);
800 error("Not struct or union");
802 Fsignal(Qwrong_type_argument,
803 list2(Qstringp, build_string("Not struct or union")));
808 lpad = align = ffi_type_align(type);
809 slots = Fcdr(XCDR(type));
811 while (!NILP(slots)) {
812 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
818 * - for basic types TMP_ALIGN and TMP_SIZE are equal
820 tmp_align = ffi_type_align(tmp_slot);
822 if (EQ(XCAR(XCAR(slots)), slot)) {
824 /* TODO: add support for :offset keyword in SLOT */
825 if (lpad < tmp_align) {
833 tmp_size = XINT(Fffi_size_of_type(tmp_slot));
834 while (tmp_size > 0) {
835 if (lpad < tmp_align) {
839 tmp_size -= tmp_align;
846 if (NILP(slots) && !NILP(slot)) {
848 signal_simple_error("FFI: Slot not found", slot);
850 signal_error(Qinternal_error, "FFI: Slot not found", slot);
853 return make_int(retoff + lpad);
857 * TYPE must be already canonicalised
860 ffi_fetch_foreign(void *ptr, Lisp_Object type)
862 /* this function canNOT GC */
863 Lisp_Object retval = Qnone;
865 if (EQ(type, Q_char))
866 retval = make_char(*(char*)ptr);
867 else if (EQ(type, Q_unsigned_char))
868 retval = make_char(*(char unsigned*)ptr);
869 else if (EQ(type, Q_byte))
870 retval = make_int(*(char*)ptr);
871 else if (EQ(type, Q_unsigned_byte))
872 retval = make_int(*(unsigned char*)ptr);
873 else if (EQ(type, Q_short))
874 retval = make_int(*(short*)ptr);
875 else if (EQ(type, Q_unsigned_short))
876 retval = make_int(*(unsigned short*)ptr);
877 else if (EQ(type, Q_int))
878 retval = make_int(*(int*)ptr);
879 else if (EQ(type, Q_unsigned_int))
880 retval = make_int(*(unsigned int*)ptr);
881 else if (EQ(type, Q_long))
882 retval = make_int(*(long*)ptr);
883 else if (EQ(type, Q_unsigned_long))
884 retval = make_int(*(unsigned long*)ptr);
885 else if (EQ(type, Q_float))
886 retval = make_float(*(float*)ptr);
887 else if (EQ(type, Q_double))
888 retval = make_float(*(double*)ptr);
889 else if (EQ(type, Q_c_string)) {
890 retval = build_ext_string((char*)ptr, Qbinary);
891 } else if (EQ(type, Q_void)) {
893 } else if (FFI_POINTERP(type)) {
894 retval = Fmake_ffi_object(type, Qnil);
895 XEFFIO(retval)->fop.ptr = *(void**)ptr;
896 } else if (CONSP(type) && EQ(XCAR(type), Q_function)) {
897 retval = Fmake_ffi_object(type, Qnil);
898 XEFFIO(retval)->fop.fun = (void*)ptr;
899 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
905 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
906 Fetch value from the foreign object FO from OFFSET position.
907 TYPE specifies value for data to be fetched.
911 Lisp_Object origtype = type;
912 Lisp_Object retval = Qnil;
913 Lisp_EffiObject *ffio;
921 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
923 type = ffi_canonicalise_type(type);
926 /* Fetch value and translate it according to translators */
927 retval = ffi_fetch_foreign(ptr, type);
928 if (EQ(retval, Qnone)) {
929 /* Special case for c-data */
930 if (EQ(type, Q_c_data) ||
931 (CONSP(type) && EQ(XCAR(type), Q_c_data)))
934 if (EQ(type, Q_c_data)) {
935 tlen = ffio->storage_size - XINT(offset);
937 CHECK_INT(XCDR(type));
938 tlen = XUINT(XCDR(type));
941 retval = make_ext_string(ptr, tlen, Qbinary);
944 signal_simple_error("Can't fetch for this type", origtype);
946 signal_error(Qinternal_error, "Can't fetch for this type",
951 retval = apply1(Findirect_function(Qffi_translate_from_foreign),
952 list2(retval, origtype));
954 RETURN_UNGCPRO(retval);
957 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
958 Return the element of FARRAY at index IDX (starting with 0).
967 type = ffi_canonicalise_type(XEFFIO(farray)->type);
968 if (!FFI_TPTR(type)) {
970 signal_simple_error("Not an array type", type);
972 signal_error(Qinternal_error, "Not an array type", type);
975 if (EQ(type, Q_c_string))
978 type = Fcar(XCDR(type));
980 return Fffi_fetch(farray,
981 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
985 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
986 For foreign object FO at specified OFFSET store data.
987 Type of data is specified by VAL-TYPE and data itself specified in VAL.
989 VAL-TYPE can be either a basic FFI type or an FFI pointer.
990 If VAL-TYPE is a basic FFI type, then VAL can be an
991 ordinary, but suitable Emacs lisp object.
992 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
993 object of the underlying type pointed to.
995 (fo, offset, val_type, val))
997 Lisp_Object origtype = val_type;
998 Lisp_EffiObject *ffio;
1005 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
1007 val_type = ffi_canonicalise_type(val_type);
1009 /* Translate value */
1010 val = apply1(Findirect_function(Qffi_translate_to_foreign),
1011 list2(val, origtype));
1013 if (EQ(val_type, Q_char) || EQ(val_type, Q_unsigned_char)) {
1015 SIGNAL_ERROR(Qwrong_type_argument,
1016 list2(Qcharacterp, val));
1018 *(char*)ptr = XCHAR(val);
1019 } else if (EQ(val_type, Q_byte) || EQ(val_type, Q_unsigned_byte)) {
1021 SIGNAL_ERROR(Qwrong_type_argument,
1022 list2(Qintegerp, val));
1024 *(char*)ptr = XINT(val);
1025 } else if (EQ(val_type, Q_short) || EQ(val_type, Q_unsigned_short)) {
1027 SIGNAL_ERROR(Qwrong_type_argument,
1028 list2(Qintegerp, val));
1030 *(short*)ptr = (short)XINT(val);
1031 } else if (EQ(val_type, Q_int) || EQ(val_type, Q_unsigned_int)) {
1033 *(int*)ptr = XINT(val);
1034 } else if (FLOATP(val)) {
1035 fpfloat tmp = XFLOATINT(val);
1036 *(int*)ptr = (int)tmp;
1038 SIGNAL_ERROR(Qwrong_type_argument,
1039 list2(Qfloatp, val));
1041 } else if (EQ(val_type, Q_long) || EQ(val_type, Q_unsigned_long)) {
1043 *(long*)ptr = (long)XINT(val);
1044 } else if (FLOATP(val)) {
1045 fpfloat tmp = XFLOATINT(val);
1046 *(long*)ptr = (long int)tmp;
1048 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1050 } else if (EQ(val_type, Q_float)) {
1052 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1053 *(float*)ptr = XFLOATINT(val);
1054 } else if (EQ(val_type, Q_double)) {
1056 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1057 *(double*)ptr = XFLOAT_DATA(val);
1058 } else if (EQ(val_type, Q_c_string)) {
1062 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1064 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1065 ALLOCA, (tmp, tmplen), Qnil);
1066 if ( tmp != NULL ) {
1067 memcpy((char*)ptr, tmp, tmplen + 1);
1071 (const char *)XSTRING_DATA(val),
1072 XSTRING_LENGTH(val) + 1);
1074 } else if (EQ(val_type, Q_c_data) ||
1076 EQ(XCAR(val_type), Q_c_data) && INTP(XCDR(val_type)))) {
1077 char *val_ext = NULL;
1078 unsigned int val_ext_len;
1080 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1082 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1083 (val_ext, val_ext_len), Qbinary);
1084 if (val_ext == NULL ||
1085 (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type))))) {
1087 error("storage size too small");
1089 Fsignal(Qrange_error,
1091 build_string("storage size too small")));
1092 #endif /* SXEMACS */
1094 memcpy((char*)ptr, (const char *)val_ext, val_ext_len);
1096 } else if (FFI_POINTERP(val_type)) {
1099 signal_simple_error("FFI: Value not of pointer type", \
1100 list2(origtype, val));
1102 Fsignal(Qwrong_type_argument,
1103 list2(Qstringp, build_string("type")));
1104 #endif /* SXEMACS */
1106 *(void**)ptr = (void*)XEFFIO(val)->fop.ptr;
1107 } else if (CONSP(val_type) && EQ(XCAR(val_type), Q_struct)) {
1110 signal_simple_error("FFI: Value not FFI object", \
1111 list2(origtype, val));
1113 Fsignal(Qwrong_type_argument,
1114 list2(Qstringp, build_string("type")));
1115 #endif /* SXEMACS */
1117 memcpy((char*)ptr, (const char *)XEFFIO(val)->fop.ptr, \
1118 XINT(Fffi_size_of_type(val_type)));
1121 signal_simple_error("FFI: Non basic or pointer type", origtype);
1123 Fsignal(Qinternal_error,
1125 build_string("non basic or pointer type")));
1126 #endif /* SXEMACS */
1132 DEFUN("ffi-aset", Fffi_aset, 3, 3, 0, /*
1133 Store the element VALUE in FARRAY at index IDX (starting with 0).
1135 (farray, idx, value))
1139 CHECK_EFFIO(farray);
1142 type = ffi_canonicalise_type(XEFFIO(farray)->type);
1143 if (!FFI_TPTR(type)) {
1145 signal_simple_error("Not an array type", type);
1147 signal_error(Qinternal_error, "Not an array type", type);
1148 #endif /* SXEMACS */
1150 if (EQ(type, Q_c_string))
1153 type = Fcar(XCDR(type));
1155 return Fffi_store(farray,
1156 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
1160 DEFUN("ffi-address-of", Fffi_address_of, 1, 1, 0, /*
1161 Return the FFI object that stores the address of given FFI object FO.
1163 This is the equivalent of the `&' operator in C.
1167 Lisp_Object newfo = Qnil;
1168 Lisp_EffiObject *ffio, *newffio;
1169 struct gcpro gcpro1;
1175 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1176 newffio = XEFFIO(newfo);
1178 newffio->fotype = EFFI_FOT_BIND;
1179 if (FFI_TPTR(ffio->type))
1180 newffio->fop.ptr = (void*)&ffio->fop.ptr;
1182 newffio->fop.ptr = ffio->fop.ptr;
1184 RETURN_UNGCPRO(newfo);
1187 DEFUN("ffi-lisp-object-to-pointer", Fffi_lisp_object_to_pointer, 1, 1, 0, /*
1188 Convert lisp object to FFI pointer.
1192 Lisp_Object newfo = Qnil;
1193 Lisp_EffiObject *newffio;
1194 struct gcpro gcpro1;
1198 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1199 newffio = XEFFIO(newfo);
1200 newffio->fotype = EFFI_FOT_BIND;
1201 newffio->fop.ptr = (void*)obj;
1203 /* Hold a reference to OBJ in NEWFO's plist */
1204 Fput(newfo, intern("lisp-object"), obj);
1206 RETURN_UNGCPRO(newfo);
1209 DEFUN("ffi-pointer-to-lisp-object", Fffi_pointer_to_lisp_object, 1, 1, 0, /*
1210 Convert FFI pointer to lisp object.
1215 return (Lisp_Object)XEFFIO(ptr)->fop.ptr;
1218 DEFUN("ffi-plist", Fffi_plist, 1, 1, 0, /*
1219 Return properties list for FFI object FO.
1224 return (XEFFIO(fo)->plist);
1229 static int lf_cindex = 0;
1233 * This will work in most cases.
1234 * However it might not work for large structures,
1235 * In general we should allocate these spaces dynamically
1237 #define MAX_TYPES_VALUES 1024
1238 /* ex_ffitypes_dummies used for structure types */
1239 static ffi_type ex_ffitypes_dummies[MAX_TYPES_VALUES + 1];
1240 static ffi_type *ex_ffitypes[MAX_TYPES_VALUES + 1];
1241 static void *ex_values[MAX_TYPES_VALUES + 1];
1243 #if SIZEOF_LONG == 4
1244 # define effi_type_ulong ffi_type_uint32
1245 # define effi_type_slong ffi_type_sint32
1246 #elif SIZEOF_LONG == 8
1247 # define effi_type_ulong ffi_type_uint64
1248 # define effi_type_slong ffi_type_sint64
1252 extffi_setup_argument(Lisp_Object type, ffi_type **ft)
1254 type = ffi_canonicalise_type(type);
1255 if (EQ(type, Q_char) || EQ(type, Q_byte))
1256 *ft = &ffi_type_schar;
1257 else if (EQ(type, Q_unsigned_char) || EQ(type, Q_unsigned_byte))
1258 *ft = &ffi_type_uchar;
1259 else if (EQ(type, Q_short))
1260 *ft = &ffi_type_sshort;
1261 else if (EQ(type, Q_unsigned_short))
1262 *ft = &ffi_type_ushort;
1263 else if (EQ(type, Q_int))
1264 *ft = &ffi_type_sint;
1265 else if (EQ(type, Q_unsigned_int))
1266 *ft = &ffi_type_uint;
1267 else if (EQ(type, Q_unsigned_long))
1268 *ft = &effi_type_ulong;
1269 else if (EQ(type, Q_long))
1270 *ft = &effi_type_slong;
1271 else if (EQ(type, Q_float))
1272 *ft = &ffi_type_float;
1273 else if (EQ(type, Q_double))
1274 *ft = &ffi_type_double;
1275 else if (EQ(type, Q_void))
1276 *ft = &ffi_type_void;
1277 else if (FFI_TPTR(type))
1278 *ft = &ffi_type_pointer;
1279 else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
1280 Lisp_Object slots = Fcdr(XCDR(type));
1286 nt_size = XINT(Flength(slots)) + 1;
1287 if (nt_size + lf_cindex > MAX_TYPES_VALUES) {
1288 lf_cindex = 0; /* reset cindex */
1290 error("cindex overflow");
1292 Fsignal(Qoverflow_error,
1294 build_string("cindex overflow")));
1295 #endif /* SXEMACS */
1297 ntypes = &ex_ffitypes[lf_cindex];
1298 *ft = &ex_ffitypes_dummies[lf_cindex];
1300 /* Update lf_cindex in case TYPE struct contains other
1302 lf_cindex += nt_size;
1304 (*ft)->type = FFI_TYPE_STRUCT;
1305 (*ft)->alignment = ffi_type_align(type);
1306 (*ft)->elements = ntypes;
1308 for (i = 0; (i < nt_size) && !NILP(slots); slots = XCDR(slots), i++)
1309 extffi_setup_argument(Fcar(Fcdr(XCAR(slots))), &ntypes[i]);
1313 signal_simple_error("Can't setup argument for type", type);
1315 signal_error(Qinternal_error,
1316 "Can't setup argument for type", type);
1317 #endif /* SXEMACS */
1322 ffi_call_using_libffi(Lisp_Object fo_fun, Lisp_Object ret_fo,
1323 int in_nargs, Lisp_Object *in_args)
1325 Lisp_EffiObject *ffio;
1332 lf_cindex = in_nargs; /* reserve */
1333 for (i = 0; i < in_nargs; i++) {
1334 ffio = XEFFIO(in_args[i]);
1335 fft = Fffi_canonicalise_type(ffio->type);
1336 extffi_setup_argument(fft, &ex_ffitypes[i]);
1338 ex_values[i] = &ffio->fop.ptr;
1340 ex_values[i] = ffio->fop.ptr;
1343 ffio = XEFFIO(ret_fo);
1344 fft = Fffi_canonicalise_type(ffio->type);
1345 extffi_setup_argument(fft, &rtype);
1347 rvalue = &ffio->fop.ptr;
1349 rvalue = ffio->fop.ptr;
1351 if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, in_nargs,
1352 rtype, ex_ffitypes) == FFI_OK)
1354 stop_async_timeouts();
1355 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1357 start_async_timeouts();
1364 #endif /* HAVE_LIBFFI */
1366 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1367 Call a function referred to by FO with arguments ARGS, maybe
1368 return a foreign object with the result or nil if there is
1371 Arguments are: FO &rest FO-ARGS
1373 FO should be a foreign binding initiated by `ffi-defun', and
1374 ARGS should be foreign data objects or pointers to these.
1376 (int nargs, Lisp_Object * args))
1378 Lisp_Object faf = Qnil, retfo = Qnil;
1379 Lisp_EffiObject *ffio;
1381 struct gcpro gcpro1, gcpro2;
1387 retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1390 ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1391 #endif /* HAVE_LIBFFI */
1393 RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1396 #ifdef EF_USE_ASYNEQ
1397 /* handler for asynchronously calling ffi code */
1398 Lisp_Object Qffi_jobp;
1399 #define EFFI_DEBUG_JOB(args...)
1401 exec_sentinel_unwind(Lisp_Object SXE_UNUSED(datum))
1407 exec_sentinel(void *job, ffi_job_t ffij)
1408 __attribute__((always_inline));
1410 exec_sentinel(void *job, ffi_job_t ffij)
1412 /* This function can GC */
1413 /* called from main thread */
1414 int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1415 Lisp_Object funcell[nargs+2];
1416 struct gcpro gcpro1;
1418 funcell[0] = ffij->sntnl;
1419 funcell[1] = (Lisp_Object)job;
1420 for (i = 0; i < nargs; i++) {
1421 funcell[2+i] = ffij->sntnl_args[i];
1423 GCPROn(funcell, nargs+2);
1425 record_unwind_protect(exec_sentinel_unwind, Qnil);
1426 /* call the funcell */
1427 Ffuncall(nargs+2, funcell);
1428 /* reset to previous state */
1429 restore_match_data();
1431 unbind_to(speccount, Qnil);
1435 static inline ffi_job_t
1436 allocate_ffi_job(void)
1438 ffi_job_t ffij = xnew(struct ffi_job_s);
1439 EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1443 static inline ffi_job_t
1444 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1445 Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1447 /* exec'd in the main thread */
1448 ffi_job_t ffij = allocate_ffi_job();
1451 SXE_MUTEX_INIT(&ffij->mtx);
1453 if (fof_nargs > 0) {
1454 ffij->fof_nargs = fof_nargs;
1455 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1456 for (i = 0; i < fof_nargs; i++) {
1457 ffij->fof_args[i] = fof_args[i];
1460 ffij->fof_nargs = 0;
1461 ffij->fof_args = NULL;
1464 ffij->sntnl = sntnl;
1465 if (sntnl_nargs > 0) {
1466 ffij->sntnl_nargs = sntnl_nargs;
1467 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1468 for (i = 0; i < sntnl_nargs; i++) {
1469 ffij->sntnl_args[i] = sntnl_args[i];
1472 ffij->sntnl_nargs = 0;
1473 ffij->sntnl_args = NULL;
1476 ffij->result = Qnil;
1477 ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1482 mark_ffi_job(worker_job_t job)
1484 ffi_job_t ffij = ffi_job(job);
1490 SXE_MUTEX_LOCK(&ffij->mtx);
1491 mark_object(ffij->fof);
1492 for (i = 0; i < ffij->fof_nargs; i++) {
1493 mark_object(ffij->fof_args[i]);
1495 mark_object(ffij->sntnl);
1496 for (i = 0; i < ffij->sntnl_nargs; i++) {
1497 mark_object(ffij->sntnl_args[i]);
1499 mark_object(ffij->retfo);
1500 mark_object(ffij->result);
1501 SXE_MUTEX_UNLOCK(&ffij->mtx);
1506 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1508 ffi_job_t ffij = ffi_job(job);
1510 SXE_MUTEX_LOCK(&ffij->mtx);
1511 WRITE_FMT_STRING(pcf, " carrying #<ffi-job 0x%lx>",
1512 (long unsigned int)ffij);
1513 SXE_MUTEX_UNLOCK(&ffij->mtx);
1518 finish_ffi_job_data(ffi_job_t ffij)
1520 SXE_MUTEX_LOCK(&ffij->mtx);
1521 xfree(ffij->fof_args);
1522 xfree(ffij->sntnl_args);
1523 SXE_MUTEX_UNLOCK(&ffij->mtx);
1524 SXE_MUTEX_FINI(&ffij->mtx);
1526 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1531 finish_ffi_job(worker_job_t job)
1535 lock_worker_job(job);
1536 ffij = ffi_job(job);
1539 finish_ffi_job_data(ffij);
1541 worker_job_data(job) = NULL;
1542 unlock_worker_job(job);
1547 ffi_job_handle(worker_job_t job)
1550 /* usually called from aux threads */
1552 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1553 int nargs, ret = -1;
1555 lock_worker_job(job);
1556 ffij = ffi_job(job);
1557 unlock_worker_job(job);
1558 SXE_MUTEX_LOCK(&ffij->mtx);
1560 nargs = ffij->fof_nargs;
1561 args = ffij->fof_args;
1562 SXE_MUTEX_UNLOCK(&ffij->mtx);
1564 /* can't ... Fmake_ffi_object is not mt-safe */
1565 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1566 retfo = ffij->retfo;
1569 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1570 #endif /* HAVE_LIBFFI */
1572 SXE_MUTEX_LOCK(&ffij->mtx);
1573 ffij->result = retfo;
1574 SXE_MUTEX_UNLOCK(&ffij->mtx);
1577 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1582 ffi_job_finished(worker_job_t job)
1584 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1587 /* called from main thread */
1588 exec_sentinel(job, ffi_job(job));
1592 static struct work_handler_s ffi_job_handler = {
1593 mark_ffi_job, print_ffi_job, finish_ffi_job,
1594 ffi_job_handle, NULL, ffi_job_finished
1598 make_ffi_asyneq_job(ffi_job_t ffij)
1600 /* create a job digestible by the asyneq */
1601 Lisp_Object job = Qnil;
1602 struct gcpro gcpro1;
1605 job = wrap_object(make_worker_job(&ffi_job_handler));
1606 XWORKER_JOB_DATA(job) = ffij;
1607 /* the scratch buffer thingie */
1612 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1613 Call a function referred to by FO with arguments ARGS asynchronously,
1614 return a job object.
1616 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1618 FO should be a foreign binding initiated by `ffi-defun'.
1619 FO-ARGS should be exactly as many foreign data objects as FO needs.
1620 SENTINEL is a lisp sentinel function called when the job finished,
1621 the function should take at least one argument JOB, further arguments
1622 may be specified by passing further SENTINEL-ARGS.
1624 (int nargs, Lisp_Object *args))
1626 Lisp_Object job = Qnil;
1627 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1628 int sntnl_nargs, fof_nargs;
1630 struct gcpro gcpro1, gcpro2;
1632 CHECK_EFFIO(args[0]);
1633 GCPRO1n(job, args, nargs);
1636 /* determine how many args belong to the fof */
1637 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1638 fof_args = &args[1];
1640 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1641 sntnl = args[fof_nargs+1];
1642 sntnl_args = &args[fof_nargs+2];
1648 /* create the job data object */
1649 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1650 sntnl, sntnl_nargs, sntnl_args);
1651 /* now prepare the job to dispatch */
1652 job = make_ffi_asyneq_job(ffij);
1653 /* ... and dispatch it, change its state to queued */
1654 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1655 eq_enqueue(delegate_eq, job);
1656 /* brag about new jobs in the queue */
1657 eq_queue_trigger_all(delegate_eq);
1662 #endif /* EF_USE_ASYNEQ */
1664 extern struct device *decode_x_device(Lisp_Object device);
1666 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1667 Return DEVICE display as FFI object.
1674 fo = Fmake_ffi_object(Q_pointer, Qnil);
1675 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1676 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1684 #define FFI_CC_CDECL 0
1686 #if defined __i386__
1688 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1690 Lisp_Object fun, alist = Qnil, retlo, foret;
1691 Lisp_Object rtype, argtypes;
1692 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1695 fun = Fcar(cbk_info);
1696 rtype = Fcar(Fcdr(cbk_info));
1697 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1699 CHECK_LIST(argtypes);
1701 arg_buffer += 4; /* Skip return address */
1702 while (!NILP(argtypes)) {
1703 Lisp_Object result, ctype;
1706 ctype = ffi_canonicalise_type(XCAR(argtypes));
1707 size = XINT(Fffi_size_of_type(ctype));
1708 if (EQ(ctype, Q_c_string)) {
1709 char *aptr = *(char**)arg_buffer;
1711 result = ffi_fetch_foreign(aptr, ctype);
1715 result = ffi_fetch_foreign(arg_buffer, ctype);
1716 /* Apply translators and put the result into alist */
1717 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1718 list2(result, XCAR(argtypes)));
1719 alist = Fcons(result, alist);
1722 int sp = (size + mask) & ~mask;
1725 argtypes = XCDR(argtypes);
1727 alist = Fnreverse(alist);
1729 /* Special case, we have no return value */
1730 if (EQ(rtype, Q_void)) {
1731 GCPRO3(fun, alist, rtype);
1737 GCPRO5(fun, alist, rtype, retlo, foret);
1738 retlo = apply1(fun, alist);
1739 foret = Fmake_ffi_object(rtype, Qnil);
1740 Fffi_store(foret, make_int(0), rtype, retlo);
1741 ptr = (void*)XEFFIO(foret)->fop.ptr;
1742 if (EQ(rtype, Q_double)) {
1745 asm volatile ("fldl (%0)" :: "a" (ptr));
1748 } else if (EQ(rtype, Q_float)) {
1751 asm volatile ("flds (%0)" :: "a" (ptr));
1757 if (EQ(rtype, Q_byte) || EQ(rtype, Q_char))
1759 else if (EQ(rtype, Q_unsigned_byte) || EQ(rtype, Q_unsigned_char))
1760 iv = *(char unsigned*)ptr;
1761 else if (EQ(rtype, Q_short))
1763 else if (EQ(rtype, Q_unsigned_short))
1764 iv = *(unsigned short*)ptr;
1769 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1776 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1780 * pushl <data> 68 <addr32>
1781 * call ffi_callback_call_x86 E8 <disp32>
1789 char *buf = xmalloc(sizeof(char)*16);
1790 *(char*) (buf+0) = 0x54;
1791 *(char*) (buf+1) = 0x68;
1792 *(long*) (buf+2) = (long)data;
1793 *(char*) (buf+6) = 0xE8;
1794 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1795 *(char*) (buf+11) = 0x59;
1796 *(char*) (buf+12) = 0x59;
1797 if (cc_type == FFI_CC_CDECL) {
1798 *(char*) (buf+13) = 0xc3;
1799 *(short*)(buf+14) = 0x9090;
1801 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1805 CHECK_CONS(arg_types);
1807 while (!NILP(arg_types)) {
1808 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1809 byte_size += ((sz+mask)&(~mask));
1810 arg_types = XCDR(arg_types);
1813 *(char*) (buf+13) = 0xc2;
1814 *(short*)(buf+14) = (short)byte_size;
1819 #endif /* __i386__ */
1821 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1822 Create dynamic callback and return pointer to it.
1824 (fun, rtype, argtypes, cctype))
1831 data = list3(fun, rtype, argtypes);
1832 /* Put data as property of the fun, so it(data) wont be GCed */
1833 Fput(fun, Q_ffi_callback, data);
1834 ptr = Fmake_ffi_object(Q_pointer, Qnil);
1836 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1837 #endif /* __i386__ */
1844 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1846 defsymbol(&Q_byte, "byte");
1847 defsymbol(&Q_unsigned_byte, "unsigned-byte");
1848 defsymbol(&Q_char, "char");
1849 defsymbol(&Q_unsigned_char, "unsigned-char");
1850 defsymbol(&Q_short, "short");
1851 defsymbol(&Q_unsigned_short, "unsigned-short");
1852 defsymbol(&Q_int, "int");
1853 defsymbol(&Q_unsigned_int, "unsigned-int");
1854 defsymbol(&Q_long, "long");
1855 defsymbol(&Q_unsigned_long, "unsigned-long");
1856 defsymbol(&Q_float, "float");
1857 defsymbol(&Q_double, "double");
1858 defsymbol(&Q_void, "void");
1859 defsymbol(&Q_pointer, "pointer");
1860 defsymbol(&Q_struct, "struct");
1861 defsymbol(&Q_union, "union");
1862 defsymbol(&Q_array, "array");
1863 defsymbol(&Q_function, "function");
1864 defsymbol(&Q_c_string, "c-string");
1865 defsymbol(&Q_c_data, "c-data");
1867 defsymbol(&Qffiobjectp, "ffiobjectp");
1869 defsymbol(&Qffi_translate_to_foreign, "ffi-translate-to-foreign");
1870 defsymbol(&Qffi_translate_from_foreign, "ffi-translate-from-foreign");
1872 defsymbol(&Q_ffi_callback, "ffi-callback");
1874 DEFSUBR(Fffi_basic_type_p);
1875 DEFSUBR(Fffi_canonicalise_type);
1876 DEFSUBR(Fffi_size_of_type);
1877 DEFSUBR(Fmake_ffi_object);
1878 DEFSUBR(Fffi_object_p);
1879 DEFSUBR(Fffi_make_pointer);
1880 DEFSUBR(Fffi_object_address);
1881 DEFSUBR(Fffi_object_canonical_type);
1882 DEFSUBR(Fffi_object_type);
1883 DEFSUBR(Fffi_object_size);
1884 DEFSUBR(Fffi_set_storage_size);
1885 DEFSUBR(Fffi_set_object_type);
1886 DEFSUBR(Fffi_fetch);
1888 DEFSUBR(Fffi_store);
1890 DEFSUBR(Fffi_address_of);
1891 DEFSUBR(Fffi_type_alignment);
1892 DEFSUBR(Fffi_slot_offset);
1893 DEFSUBR(Fffi_load_library);
1895 DEFSUBR(Fffi_dlerror);
1896 DEFSUBR(Fffi_defun);
1897 DEFSUBR(Fffi_call_function);
1899 DEFSUBR(Fffi_lisp_object_to_pointer);
1900 DEFSUBR(Fffi_pointer_to_lisp_object);
1901 DEFSUBR(Fffi_plist);
1903 #ifdef EF_USE_ASYNEQ
1904 DEFSUBR(Fffi_call_functionX);
1905 defsymbol(&Qffi_jobp, "ffi-job-p");
1908 DEFSUBR(Fx_device_display);
1910 DEFSUBR(Fffi_make_callback);
1914 reinit_vars_of_ffi(void)
1916 staticpro_nodump(&Vffi_all_objects);
1917 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1923 reinit_vars_of_ffi();
1925 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1926 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1928 Vffi_named_types = Qnil;
1930 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1931 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1933 Vffi_loaded_libraries = Qnil;
1935 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1936 Function to call when the validity of an FFI type shall be checked.
1938 Vffi_type_checker = intern("ffi-type-p");