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 LRECORD_DESCRIPTION lrecord_description
60 # define SIGNAL_ERROR Fsignal
61 # define FFIBYTE Ibyte
62 # define WRITE_C_STRING(x,y) write_c_string((y),(x))
63 # define LRECORD_DESCRIPTION memory_description
68 * byte, ubyte, char, uchar,
69 * short, ushort, int, uint,
72 * void, pointer, c-string
76 * (function RET-TYPE IN-TYPE .. IN-TYPE)
82 * Structures and unions types:
92 * pointer or (pointer TYPE)
96 Lisp_Object Q_byte, Q_unsigned_byte;
97 Lisp_Object Q_char, Q_unsigned_char;
98 Lisp_Object Q_short, Q_unsigned_short;
99 Lisp_Object Q_int, Q_unsigned_int;
100 Lisp_Object Q_long, Q_unsigned_long;
101 Lisp_Object Q_float, Q_double;
103 Lisp_Object Q_array, Q_pointer;
104 Lisp_Object Q_union, Q_struct;
105 Lisp_Object Q_function;
106 Lisp_Object Q_c_string, Q_c_data;
108 #define FFI_POINTERP(type) (EQ(type, Q_pointer) \
109 || (CONSP(type) && EQ(XCAR(type), Q_pointer)))
111 #define FFI_TPTR(type) (EQ(type, Q_c_string) \
112 || EQ(type, Q_c_data) \
113 || FFI_POINTERP(type) \
114 || (CONSP(type) && ((EQ(XCAR(type), Q_c_data)) \
115 || EQ(XCAR(type), Q_array))))
117 Lisp_Object Qffiobjectp;
118 Lisp_Object Qffi_translate_to_foreign;
119 Lisp_Object Qffi_translate_from_foreign;
121 /* Alist with elements in form (NAME . TYPE) */
122 Lisp_Object Vffi_loaded_libraries;
123 Lisp_Object Vffi_named_types;
125 Lisp_Object Vffi_type_checker;
127 static Lisp_Object Vffi_all_objects;
129 Lisp_Object Q_ffi_callback;
132 mark_ffiobject(Lisp_Object obj)
134 Lisp_EffiObject *ffio = XEFFIO(obj);
135 mark_object(ffio->type);
136 mark_object(ffio->size);
137 mark_object(ffio->plist);
138 return (ffio->plist);
142 print_ffiobject(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
144 /* This function can GC */
145 Lisp_EffiObject *ffio = XEFFIO(obj);
148 escapeflag = escapeflag; /* shutup compiler */
149 if (print_readably) {
151 error("printing unreadable object #<ffiobject 0x%x>",
154 signal_ferror(Qinternal_error,
155 "printing unreadable object #<ffiobject 0x%x>",
159 WRITE_C_STRING("#<ffiobject ", printcharfun);
160 /* Print FFIO type */
161 if (!NILP(ffio->type)) {
162 WRITE_C_STRING("type=", printcharfun);
163 print_internal(ffio->type, printcharfun, 1);
164 WRITE_C_STRING(" ", printcharfun);
166 snprintf(buf, 255, "size=%ld fotype=%d foptr=%p>",
167 (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
168 WRITE_C_STRING(buf, printcharfun);
171 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
172 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
173 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
174 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
175 {XD_INT, offsetof(Lisp_EffiObject, fotype)},
176 {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
178 {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
180 {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
186 ffi_getprop(Lisp_Object fo, Lisp_Object property)
188 return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
192 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
194 external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
199 ffi_remprop(Lisp_Object fo, Lisp_Object property)
201 return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
206 sizeof_ffiobject(const void *header)
208 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
209 return (sizeof(Lisp_EffiObject) + effio->storage_size);
213 sizeof_ffiobject(const void *header)
215 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
216 return (sizeof(Lisp_EffiObject) + effio->storage_size);
220 /* Define ffiobject implementation */
221 const struct lrecord_implementation lrecord_ffiobject = {
223 .marker = mark_ffiobject,
224 .printer = print_ffiobject,
228 .description = ffiobject_description,
229 .getprop = ffi_getprop,
230 .putprop = ffi_putprop,
231 .remprop = ffi_remprop,
234 .size_in_bytes_method = sizeof_ffiobject,
235 .lrecord_type_index = lrecord_type_ffiobject,
240 /** alignment in union and structures **/
244 * - An entire structure or union is aligned on the same boundary as
245 * its most strictly aligned member.
247 * - Each member is assigned to the lowest available offset with the
248 * appropriate alignment. This may require /internal padding/,
249 * depending on the previous member.
251 * - A structure's size is increased, if necessary, to make it a
252 * multiple of the alignment. This may require /tail padding/,
253 * depending on the last member.
258 * char c; .-------2+---1+---0.
259 * short s; | s |pad | c |
260 * } `--------+----+----'
262 * Internal and Tail padding:
264 * struct { .------------1+---0.
265 * char c; | pad | c |
266 * double d; |-------------+---4|
268 * } |-----------------8|
270 * |------14+-------12|
272 * `--------+---------'
276 * union { .------------1+---0.
277 * char c; | pad | c |
278 * short s; |-------2+----+---0|
280 * } |--------+--------0|
282 * `------------------'
285 ffi_check_type(Lisp_Object type)
287 return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
290 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
291 Return non-nil if TYPE is a basic FFI type.
293 A type is said to be basic, if it is neither a pointer nor a
294 function, and there is a corresponding built-in type in C.
298 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte) || EQ(type, Q_char)
299 || EQ(type, Q_unsigned_char) || EQ(type, Q_short)
300 || EQ(type, Q_unsigned_short) || EQ(type, Q_int)
301 || EQ(type, Q_unsigned_int) || EQ(type, Q_long)
302 || EQ(type, Q_unsigned_long) || EQ(type, Q_float)
303 || EQ(type, Q_double) || EQ(type, Q_void)
304 || EQ(type, Q_c_string) || EQ(type, Q_c_data)
305 || (CONSP(type) && EQ(XCAR(type), Q_c_data)))
313 ffi_canonicalise_type(Lisp_Object type)
315 /* this function canNOT GC */
317 while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
318 if EQ(type, Q_pointer)
320 type = Fcdr(Fassq(type, Vffi_named_types));
326 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
327 Return FFI type TYPE in a canonical form.
331 Lisp_Object canon_type = ffi_canonicalise_type(type);
332 if (NILP(canon_type)) {
334 signal_simple_error("No such FFI type", type);
336 signal_error(Qinternal_error, "No such FFI type", type);
342 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0, /*
343 Return the size of the foreign type TYPE.
345 Valid foreign types are: `byte', `unsigned-byte', `char',
346 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
347 `long', `unsigned-long', `pointer', `float', `double',
348 `object', and `c-string'.
354 type = ffi_canonicalise_type(type);
355 if (EQ(type, Q_void))
357 else if (EQ(type, Q_byte))
358 tsize = sizeof(int8_t);
359 else if (EQ(type, Q_unsigned_byte))
360 tsize = sizeof(uint8_t);
361 else if (EQ(type, Q_char))
362 tsize = sizeof(char);
363 else if (EQ(type, Q_unsigned_char))
364 tsize = sizeof(unsigned char);
365 else if (EQ(type, Q_short))
366 tsize = sizeof(short);
367 else if (EQ(type, Q_unsigned_short))
368 tsize = sizeof(unsigned short);
369 else if (EQ(type, Q_int))
371 else if (EQ(type, Q_unsigned_int))
372 tsize = sizeof(unsigned int);
373 else if (EQ(type, Q_long))
374 tsize = sizeof(long);
375 else if (EQ(type, Q_unsigned_long))
376 tsize = sizeof(unsigned long);
377 else if (EQ(type, Q_float))
378 tsize = sizeof(float);
379 else if (EQ(type, Q_double))
380 tsize = sizeof(double);
381 else if (EQ(type, Q_c_string))
382 tsize = sizeof(char *);
383 else if (FFI_POINTERP(type))
384 tsize = sizeof(void *);
385 else if (EQ(type, Q_c_data))
386 tsize = sizeof(void *);
387 else if (CONSP(type) && EQ(XCAR(type), Q_c_data)) {
388 Lisp_Object cdsize = XCDR(type);
390 tsize = XINT(cdsize);
391 } else if (CONSP(type) && EQ(XCAR(type), Q_function))
392 tsize = sizeof(void(*));
393 else if (CONSP(type) && EQ(XCAR(type), Q_array)) {
394 Lisp_Object atype = Fcar(XCDR(type));
395 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
398 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
399 } else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
400 return Fffi_slot_offset(type, Qnil);
401 } else if (CONSP(type) && EQ(XCAR(type), Q_union)) {
402 Lisp_Object slots = Fcdr(XCDR(type));
407 while (!NILP(slots)) {
408 Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
409 int slot_size = XINT(Fffi_size_of_type(slot_type));
410 if (slot_size > tsize)
416 signal_simple_error("Unrecognized foreign type", type);
418 signal_error(Qinternal_error, "Unrecognized foreign type", type);
422 return make_int(tsize);
425 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
426 Create a new FFI object of type TYPE.
427 If optional argument SIZE is non-nil it should be an
428 integer, in this case additional storage size to hold data
429 of at least length SIZE is allocated.
435 Lisp_Object result = Qnil;
436 Lisp_EffiObject *ffio;
441 /* NOTE: ffi_check_type returns canonical type */
442 ctype = ffi_check_type(type);
444 size = Fffi_size_of_type(type);
447 if (CONSP(ctype) && EQ(XCAR(ctype), Q_c_data) && INTP(XCDR(ctype)))
450 cs_or_cd = EQ(ctype, Q_c_string) || (EQ(ctype, Q_c_data));
451 if ((cs_or_cd && (XINT(size) < 1))
452 || (!(cs_or_cd || FFI_POINTERP(ctype))
453 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
455 signal_simple_error("storage size too small to store type",
458 ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
460 XSETEFFIO(result, ffio);
462 signal_error(Qinternal_error,
463 "storage size too small to store type",
466 ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
468 result = wrap_effio(ffio);
471 ffio->size = Fffi_size_of_type(type);
475 /* Initialize foreign pointer */
476 ffio->fotype = EFFI_FOT_NONE;
477 ffio->storage_size = XINT(size);
478 ffio->fop.ptr = ffio->fostorage;
480 if (!NILP(Vffi_all_objects))
481 XWEAK_LIST_LIST(Vffi_all_objects) =
482 Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
484 RETURN_UNGCPRO(result);
487 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
488 Return non-nil if FO is an FFI object, nil otherwise.
492 return (EFFIOP(fo) ? Qt : Qnil);
495 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
496 Return the address FO points to.
501 return make_float((long)XEFFIO(fo)->fop.ptr);
504 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
505 "Return a pointer pointing to ADDRESS."
513 addr = XINT(address);
514 else if (FLOATP(address))
515 addr = XFLOATINT(address);
518 signal_simple_error("FFI: invalid address type", address);
520 signal_error(Qinternal_error, "FFI: invalid address type",
525 ptr = Fmake_ffi_object(Q_pointer, Qnil);
526 XEFFIO(ptr)->fop.ptr = (void*)addr;
530 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
531 Return FO's real type, that is after resolving user defined types.
536 return ffi_canonicalise_type(XEFFIO(fo)->type);
539 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
545 return (XEFFIO(fo)->type);
548 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
549 Cast FO to type TYPE and reassign the cast value.
555 ffi_check_type(type);
556 XEFFIO(fo)->type = type;
561 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
562 Return the size of the allocated space of FO.
567 return (XEFFIO(fo)->size);
570 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
571 Set the size of the allocated space of FO.
577 XEFFIO(fo)->storage_size = XUINT(size);
581 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
582 Load library LIBNAME and return a foreign object handle if successful,
583 or `nil' if the library cannot be loaded.
585 The argument LIBNAME should be the file-name string of a shared object
586 library. Normally you should omit the file extension, as this
587 function will add the appripriate extension for the current platform
590 The library should reside in one of the directories specified by the
591 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
596 #ifdef LTDL_SHLIB_EXT
597 # define EXT LTDL_SHLIB_EXT
598 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
599 # define EXT ".dylib"
602 #endif /* LTDL_SHLIB_EXT */
604 void *handler, *dotpos;
605 Lisp_Object fo = Qnil;
606 Lisp_EffiObject *ffio;
610 CHECK_STRING(libname);
612 /* Add an extension if we need to */
613 dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
614 if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
615 ssize_t liblen = XSTRING_LENGTH(libname);
616 ssize_t soname_len = liblen + sizeof(EXT);
617 soname = xmalloc( soname_len + 1);
618 strncpy(soname, (char *)XSTRING_DATA(libname), liblen+1);
619 strncat(soname, EXT, sizeof(EXT)+1);
622 if ( soname == NULL ) {
623 handler = dlopen((const char *)XSTRING_DATA(libname),
624 RTLD_GLOBAL|RTLD_NOW);
626 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
634 fo = Fmake_ffi_object(Q_pointer, Qnil);
637 ffio->fotype = EFFI_FOT_BIND;
638 ffio->fop.ptr = handler;
643 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
644 Make and return a foreign object of type TYPE and bind it to the
647 The argument TYPE can be any type-cell.
648 The argument SYM should be a string naming an arbitrary symbol
649 in one of the loaded libraries.
651 If SYM does not exist in any of the loaded libraries, `nil' is
656 Lisp_Object fo = Qnil;
657 Lisp_EffiObject *ffio;
660 ffi_check_type(type);
664 fo = Fmake_ffi_object(type, Qnil);
666 ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
667 if (ffio->fop.ptr == NULL) {
672 ffio->fotype = EFFI_FOT_BIND;
677 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
678 Return dl error string.
682 const char *dles = dlerror();
684 if (LIKELY(dles != NULL)) {
685 size_t sz = strlen(dles);
686 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
692 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
693 Make and return a foreign object of type TYPE and bind it to the
696 The argument TYPE should be a function type-cell.
697 The argument SYM should be a string naming a function in one of
698 the loaded libraries.
700 If SYM does not exist in any of the loaded libraries, an error
703 This is like `ffi-bind' but for function objects.
707 Lisp_Object fo = Qnil;
708 Lisp_EffiObject *ffio;
711 ffi_check_type(type);
716 fo = Fmake_ffi_object(type, Qnil);
718 ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
719 if (ffio->fop.fun == NULL) {
721 signal_simple_error("Can't define function", sym);
723 signal_error(Qinternal_error, "Can't define function", sym);
727 ffio->fotype = EFFI_FOT_FUNC;
733 * Return alignment policy for struct or union FFI_SU.
734 * x86: Return 1, 2 or 4.
735 * mips: Return 1, 2, 4 or 8.
738 ffi_type_align(Lisp_Object type)
740 type = ffi_canonicalise_type(type);
742 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte)
743 || EQ(type, Q_char) || EQ(type, Q_unsigned_char))
745 if (EQ(type, Q_short) || EQ(type, Q_unsigned_short))
748 if (EQ(type, Q_double))
750 #endif /* FFI_MIPS */
753 } else if (CONSP(type)
754 && (EQ(XCAR(type), Q_struct) || EQ(XCAR(type), Q_union))) {
757 for (al = 0, type = Fcdr(Fcdr(type));
761 Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
762 int tmp_al = ffi_type_align(stype);
774 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
775 Return TYPE alignment.
779 return make_int(ffi_type_align(type));
782 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
783 Return the offset of SLOT in TYPE.
784 SLOT can be either a valid (named) slot in TYPE or `nil'.
785 If SLOT is `nil' return the size of the struct.
790 int lpad, align, retoff;
792 type = ffi_canonicalise_type(type);
795 error("Not struct or union");
797 Fsignal(Qwrong_type_argument,
798 list2(Qstringp, build_string("Not struct or union")));
803 lpad = align = ffi_type_align(type);
804 slots = Fcdr(XCDR(type));
806 while (!NILP(slots)) {
807 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
813 * - for basic types TMP_ALIGN and TMP_SIZE are equal
815 tmp_align = ffi_type_align(tmp_slot);
817 if (EQ(XCAR(XCAR(slots)), slot)) {
819 /* TODO: add support for :offset keyword in SLOT */
820 if (lpad < tmp_align) {
828 tmp_size = XINT(Fffi_size_of_type(tmp_slot));
829 while (tmp_size > 0) {
830 if (lpad < tmp_align) {
834 tmp_size -= tmp_align;
841 if (NILP(slots) && !NILP(slot)) {
843 signal_simple_error("FFI: Slot not found", slot);
845 signal_error(Qinternal_error, "FFI: Slot not found", slot);
848 return make_int(retoff + lpad);
852 * TYPE must be already canonicalised
855 ffi_fetch_foreign(void *ptr, Lisp_Object type)
857 /* this function canNOT GC */
858 Lisp_Object retval = Qnone;
860 if (EQ(type, Q_char))
861 retval = make_char(*(char*)ptr);
862 else if (EQ(type, Q_unsigned_char))
863 retval = make_char(*(char unsigned*)ptr);
864 else if (EQ(type, Q_byte))
865 retval = make_int(*(char*)ptr);
866 else if (EQ(type, Q_unsigned_byte))
867 retval = make_int(*(unsigned char*)ptr);
868 else if (EQ(type, Q_short))
869 retval = make_int(*(short*)ptr);
870 else if (EQ(type, Q_unsigned_short))
871 retval = make_int(*(unsigned short*)ptr);
872 else if (EQ(type, Q_int))
873 retval = make_int(*(int*)ptr);
874 else if (EQ(type, Q_unsigned_int))
875 retval = make_int(*(unsigned int*)ptr);
876 else if (EQ(type, Q_long))
877 retval = make_int(*(long*)ptr);
878 else if (EQ(type, Q_unsigned_long))
879 retval = make_int(*(unsigned long*)ptr);
880 else if (EQ(type, Q_float))
881 retval = make_float(*(float*)ptr);
882 else if (EQ(type, Q_double))
883 retval = make_float(*(double*)ptr);
884 else if (EQ(type, Q_c_string)) {
885 retval = build_ext_string((char*)ptr, Qbinary);
886 } else if (EQ(type, Q_void)) {
888 } else if (FFI_POINTERP(type)) {
889 retval = Fmake_ffi_object(type, Qnil);
890 XEFFIO(retval)->fop.ptr = *(void**)ptr;
891 } else if (CONSP(type) && EQ(XCAR(type), Q_function)) {
892 retval = Fmake_ffi_object(type, Qnil);
893 XEFFIO(retval)->fop.fun = (void*)ptr;
894 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
900 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
901 Fetch value from the foreign object FO from OFFSET position.
902 TYPE specifies value for data to be fetched.
906 Lisp_Object origtype = type;
907 Lisp_Object retval = Qnil;
908 Lisp_EffiObject *ffio;
916 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
918 type = ffi_canonicalise_type(type);
921 /* Fetch value and translate it according to translators */
922 retval = ffi_fetch_foreign(ptr, type);
923 if (EQ(retval, Qnone)) {
924 /* Special case for c-data */
925 if (EQ(type, Q_c_data) ||
926 (CONSP(type) && EQ(XCAR(type), Q_c_data)))
929 if (EQ(type, Q_c_data)) {
930 tlen = ffio->storage_size - XINT(offset);
932 CHECK_INT(XCDR(type));
933 tlen = XUINT(XCDR(type));
936 retval = make_ext_string(ptr, tlen, Qbinary);
939 signal_simple_error("Can't fetch for this type", origtype);
941 signal_error(Qinternal_error, "Can't fetch for this type",
946 retval = apply1(Findirect_function(Qffi_translate_from_foreign),
947 list2(retval, origtype));
949 RETURN_UNGCPRO(retval);
952 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
953 Return the element of FARRAY at index IDX (starting with 0).
962 type = ffi_canonicalise_type(XEFFIO(farray)->type);
963 if (!FFI_TPTR(type)) {
965 signal_simple_error("Not an array type", type);
967 signal_error(Qinternal_error, "Not an array type", type);
970 if (EQ(type, Q_c_string))
973 type = Fcar(XCDR(type));
975 return Fffi_fetch(farray,
976 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
980 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
981 For foreign object FO at specified OFFSET store data.
982 Type of data is specified by VAL-TYPE and data itself specified in VAL.
984 VAL-TYPE can be either a basic FFI type or an FFI pointer.
985 If VAL-TYPE is a basic FFI type, then VAL can be an
986 ordinary, but suitable Emacs lisp object.
987 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
988 object of the underlying type pointed to.
990 (fo, offset, val_type, val))
992 Lisp_Object origtype = val_type;
993 Lisp_EffiObject *ffio;
1000 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
1002 val_type = ffi_canonicalise_type(val_type);
1004 /* Translate value */
1005 val = apply1(Findirect_function(Qffi_translate_to_foreign),
1006 list2(val, origtype));
1008 if (EQ(val_type, Q_char) || EQ(val_type, Q_unsigned_char)) {
1010 SIGNAL_ERROR(Qwrong_type_argument,
1011 list2(Qcharacterp, val));
1013 *(char*)ptr = XCHAR(val);
1014 } else if (EQ(val_type, Q_byte) || EQ(val_type, Q_unsigned_byte)) {
1016 SIGNAL_ERROR(Qwrong_type_argument,
1017 list2(Qintegerp, val));
1019 *(char*)ptr = XINT(val);
1020 } else if (EQ(val_type, Q_short) || EQ(val_type, Q_unsigned_short)) {
1022 SIGNAL_ERROR(Qwrong_type_argument,
1023 list2(Qintegerp, val));
1025 *(short*)ptr = (short)XINT(val);
1026 } else if (EQ(val_type, Q_int) || EQ(val_type, Q_unsigned_int)) {
1028 *(int*)ptr = XINT(val);
1029 } else if (FLOATP(val)) {
1030 fpfloat tmp = XFLOATINT(val);
1031 *(int*)ptr = (int)tmp;
1033 SIGNAL_ERROR(Qwrong_type_argument,
1034 list2(Qfloatp, val));
1036 } else if (EQ(val_type, Q_long) || EQ(val_type, Q_unsigned_long)) {
1038 *(long*)ptr = (long)XINT(val);
1039 } else if (FLOATP(val)) {
1040 fpfloat tmp = XFLOATINT(val);
1041 *(long*)ptr = (long int)tmp;
1043 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1045 } else if (EQ(val_type, Q_float)) {
1047 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1048 *(float*)ptr = XFLOATINT(val);
1049 } else if (EQ(val_type, Q_double)) {
1051 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1052 *(double*)ptr = XFLOAT_DATA(val);
1053 } else if (EQ(val_type, Q_c_string)) {
1057 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1059 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1060 ALLOCA, (tmp, tmplen), Qnil);
1061 memcpy((char*)ptr, tmp, tmplen + 1);
1064 (const char *)XSTRING_DATA(val),
1065 XSTRING_LENGTH(val) + 1);
1067 } else if (EQ(val_type, Q_c_data) ||
1069 EQ(XCAR(val_type), Q_c_data) && INTP(XCDR(val_type)))) {
1071 unsigned int val_ext_len;
1073 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1075 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1076 (val_ext, val_ext_len), Qbinary);
1077 if (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type)))) {
1079 error("storage size too small");
1081 Fsignal(Qrange_error,
1083 build_string("storage size too small")));
1084 #endif /* SXEMACS */
1086 memcpy((char*)ptr, (const char *)val_ext, val_ext_len);
1087 } else if (FFI_POINTERP(val_type)) {
1090 signal_simple_error("FFI: Value not of pointer type", \
1091 list2(origtype, val));
1093 Fsignal(Qwrong_type_argument,
1094 list2(Qstringp, build_string("type")));
1095 #endif /* SXEMACS */
1097 *(void**)ptr = (void*)XEFFIO(val)->fop.ptr;
1098 } else if (CONSP(val_type) && EQ(XCAR(val_type), Q_struct)) {
1101 signal_simple_error("FFI: Value not FFI object", \
1102 list2(origtype, val));
1104 Fsignal(Qwrong_type_argument,
1105 list2(Qstringp, build_string("type")));
1106 #endif /* SXEMACS */
1108 memcpy((char*)ptr, (const char *)XEFFIO(val)->fop.ptr, \
1109 XINT(Fffi_size_of_type(val_type)));
1112 signal_simple_error("FFI: Non basic or pointer type", origtype);
1114 Fsignal(Qinternal_error,
1116 build_string("non basic or pointer type")));
1117 #endif /* SXEMACS */
1123 DEFUN("ffi-aset", Fffi_aset, 3, 3, 0, /*
1124 Store the element VALUE in FARRAY at index IDX (starting with 0).
1126 (farray, idx, value))
1130 CHECK_EFFIO(farray);
1133 type = ffi_canonicalise_type(XEFFIO(farray)->type);
1134 if (!FFI_TPTR(type)) {
1136 signal_simple_error("Not an array type", type);
1138 signal_error(Qinternal_error, "Not an array type", type);
1139 #endif /* SXEMACS */
1141 if (EQ(type, Q_c_string))
1144 type = Fcar(XCDR(type));
1146 return Fffi_store(farray,
1147 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
1151 DEFUN("ffi-address-of", Fffi_address_of, 1, 1, 0, /*
1152 Return the FFI object that stores the address of given FFI object FO.
1154 This is the equivalent of the `&' operator in C.
1158 Lisp_Object newfo = Qnil;
1159 Lisp_EffiObject *ffio, *newffio;
1160 struct gcpro gcpro1;
1166 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1167 newffio = XEFFIO(newfo);
1169 newffio->fotype = EFFI_FOT_BIND;
1170 if (FFI_TPTR(ffio->type))
1171 newffio->fop.ptr = (void*)&ffio->fop.ptr;
1173 newffio->fop.ptr = ffio->fop.ptr;
1175 RETURN_UNGCPRO(newfo);
1178 DEFUN("ffi-lisp-object-to-pointer", Fffi_lisp_object_to_pointer, 1, 1, 0, /*
1179 Convert lisp object to FFI pointer.
1183 Lisp_Object newfo = Qnil;
1184 Lisp_EffiObject *newffio;
1185 struct gcpro gcpro1;
1189 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1190 newffio = XEFFIO(newfo);
1191 newffio->fotype = EFFI_FOT_BIND;
1192 newffio->fop.ptr = (void*)obj;
1194 /* Hold a reference to OBJ in NEWFO's plist */
1195 Fput(newfo, intern("lisp-object"), obj);
1197 RETURN_UNGCPRO(newfo);
1200 DEFUN("ffi-pointer-to-lisp-object", Fffi_pointer_to_lisp_object, 1, 1, 0, /*
1201 Convert FFI pointer to lisp object.
1206 return (Lisp_Object)XEFFIO(ptr)->fop.ptr;
1209 DEFUN("ffi-plist", Fffi_plist, 1, 1, 0, /*
1210 Return properties list for FFI object FO.
1215 return (XEFFIO(fo)->plist);
1220 static int lf_cindex = 0;
1224 * This will work in most cases.
1225 * However it might not work for large structures,
1226 * In general we should allocate these spaces dynamically
1228 #define MAX_TYPES_VALUES 1024
1229 /* ex_ffitypes_dummies used for structure types */
1230 static ffi_type ex_ffitypes_dummies[MAX_TYPES_VALUES + 1];
1231 static ffi_type *ex_ffitypes[MAX_TYPES_VALUES + 1];
1232 static void *ex_values[MAX_TYPES_VALUES + 1];
1234 #if SIZEOF_LONG == 4
1235 # define effi_type_ulong ffi_type_uint32
1236 # define effi_type_slong ffi_type_sint32
1237 #elif SIZEOF_LONG == 8
1238 # define effi_type_ulong ffi_type_uint64
1239 # define effi_type_slong ffi_type_sint64
1243 extffi_setup_argument(Lisp_Object type, ffi_type **ft)
1245 type = ffi_canonicalise_type(type);
1246 if (EQ(type, Q_char) || EQ(type, Q_byte))
1247 *ft = &ffi_type_schar;
1248 else if (EQ(type, Q_unsigned_char) || EQ(type, Q_unsigned_byte))
1249 *ft = &ffi_type_uchar;
1250 else if (EQ(type, Q_short))
1251 *ft = &ffi_type_sshort;
1252 else if (EQ(type, Q_unsigned_short))
1253 *ft = &ffi_type_ushort;
1254 else if (EQ(type, Q_int))
1255 *ft = &ffi_type_sint;
1256 else if (EQ(type, Q_unsigned_int))
1257 *ft = &ffi_type_uint;
1258 else if (EQ(type, Q_unsigned_long))
1259 *ft = &effi_type_ulong;
1260 else if (EQ(type, Q_long))
1261 *ft = &effi_type_slong;
1262 else if (EQ(type, Q_float))
1263 *ft = &ffi_type_float;
1264 else if (EQ(type, Q_double))
1265 *ft = &ffi_type_double;
1266 else if (EQ(type, Q_void))
1267 *ft = &ffi_type_void;
1268 else if (FFI_TPTR(type))
1269 *ft = &ffi_type_pointer;
1270 else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
1271 Lisp_Object slots = Fcdr(XCDR(type));
1277 nt_size = XINT(Flength(slots)) + 1;
1278 if (nt_size + lf_cindex > MAX_TYPES_VALUES) {
1279 lf_cindex = 0; /* reset cindex */
1281 error("cindex overflow");
1283 Fsignal(Qoverflow_error,
1285 build_string("cindex overflow")));
1286 #endif /* SXEMACS */
1288 ntypes = &ex_ffitypes[lf_cindex];
1289 *ft = &ex_ffitypes_dummies[lf_cindex];
1291 /* Update lf_cindex in case TYPE struct contains other
1293 lf_cindex += nt_size;
1295 (*ft)->type = FFI_TYPE_STRUCT;
1296 (*ft)->alignment = ffi_type_align(type);
1297 (*ft)->elements = ntypes;
1299 for (i = 0; (i < nt_size) && !NILP(slots); slots = XCDR(slots), i++)
1300 extffi_setup_argument(Fcar(Fcdr(XCAR(slots))), &ntypes[i]);
1304 signal_simple_error("Can't setup argument for type", type);
1306 signal_error(Qinternal_error,
1307 "Can't setup argument for type", type);
1308 #endif /* SXEMACS */
1313 ffi_call_using_libffi(Lisp_Object fo_fun, Lisp_Object ret_fo,
1314 int in_nargs, Lisp_Object *in_args)
1316 Lisp_EffiObject *ffio;
1323 lf_cindex = in_nargs; /* reserve */
1324 for (i = 0; i < in_nargs; i++) {
1325 ffio = XEFFIO(in_args[i]);
1326 fft = Fffi_canonicalise_type(ffio->type);
1327 extffi_setup_argument(fft, &ex_ffitypes[i]);
1329 ex_values[i] = &ffio->fop.ptr;
1331 ex_values[i] = ffio->fop.ptr;
1334 ffio = XEFFIO(ret_fo);
1335 fft = Fffi_canonicalise_type(ffio->type);
1336 extffi_setup_argument(fft, &rtype);
1338 rvalue = &ffio->fop.ptr;
1340 rvalue = ffio->fop.ptr;
1342 if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, in_nargs,
1343 rtype, ex_ffitypes) == FFI_OK)
1345 stop_async_timeouts();
1346 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1348 start_async_timeouts();
1355 #endif /* HAVE_LIBFFI */
1357 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1358 Call a function referred to by FO with arguments ARGS, maybe
1359 return a foreign object with the result or nil if there is
1362 Arguments are: FO &rest FO-ARGS
1364 FO should be a foreign binding initiated by `ffi-defun', and
1365 ARGS should be foreign data objects or pointers to these.
1367 (int nargs, Lisp_Object * args))
1369 Lisp_Object faf = Qnil, retfo = Qnil;
1370 Lisp_EffiObject *ffio;
1372 struct gcpro gcpro1, gcpro2;
1378 retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1381 ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1382 #endif /* HAVE_LIBFFI */
1384 RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1387 #ifdef EF_USE_ASYNEQ
1388 /* handler for asynchronously calling ffi code */
1389 Lisp_Object Qffi_jobp;
1390 #define EFFI_DEBUG_JOB(args...)
1392 exec_sentinel_unwind(Lisp_Object UNUSED(datum))
1398 exec_sentinel(void *job, ffi_job_t ffij)
1399 __attribute__((always_inline));
1401 exec_sentinel(void *job, ffi_job_t ffij)
1403 /* This function can GC */
1404 /* called from main thread */
1405 int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1406 Lisp_Object funcell[nargs+2];
1407 struct gcpro gcpro1;
1409 funcell[0] = ffij->sntnl;
1410 funcell[1] = (Lisp_Object)job;
1411 for (i = 0; i < nargs; i++) {
1412 funcell[2+i] = ffij->sntnl_args[i];
1414 GCPROn(funcell, nargs+2);
1416 record_unwind_protect(exec_sentinel_unwind, Qnil);
1417 /* call the funcell */
1418 Ffuncall(nargs+2, funcell);
1419 /* reset to previous state */
1420 restore_match_data();
1422 unbind_to(speccount, Qnil);
1426 static inline ffi_job_t
1427 allocate_ffi_job(void)
1429 ffi_job_t ffij = xnew(struct ffi_job_s);
1430 EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1434 static inline ffi_job_t
1435 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1436 Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1438 /* exec'd in the main thread */
1439 ffi_job_t ffij = allocate_ffi_job();
1442 SXE_MUTEX_INIT(&ffij->mtx);
1444 if (fof_nargs > 0) {
1445 ffij->fof_nargs = fof_nargs;
1446 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1447 for (i = 0; i < fof_nargs; i++) {
1448 ffij->fof_args[i] = fof_args[i];
1451 ffij->fof_nargs = 0;
1452 ffij->fof_args = NULL;
1455 ffij->sntnl = sntnl;
1456 if (sntnl_nargs > 0) {
1457 ffij->sntnl_nargs = sntnl_nargs;
1458 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1459 for (i = 0; i < sntnl_nargs; i++) {
1460 ffij->sntnl_args[i] = sntnl_args[i];
1463 ffij->sntnl_nargs = 0;
1464 ffij->sntnl_args = NULL;
1467 ffij->result = Qnil;
1468 ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1473 mark_ffi_job(worker_job_t job)
1475 ffi_job_t ffij = ffi_job(job);
1481 SXE_MUTEX_LOCK(&ffij->mtx);
1482 mark_object(ffij->fof);
1483 for (i = 0; i < ffij->fof_nargs; i++) {
1484 mark_object(ffij->fof_args[i]);
1486 mark_object(ffij->sntnl);
1487 for (i = 0; i < ffij->sntnl_nargs; i++) {
1488 mark_object(ffij->sntnl_args[i]);
1490 mark_object(ffij->retfo);
1491 mark_object(ffij->result);
1492 SXE_MUTEX_UNLOCK(&ffij->mtx);
1497 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1499 ffi_job_t ffij = ffi_job(job);
1500 char *str = alloca(64);
1502 SXE_MUTEX_LOCK(&ffij->mtx);
1503 WRITE_C_STRING(" carrying ", pcf);
1504 snprintf(str, 63, " #<ffi-job 0x%lx>", (long unsigned int)ffij);
1505 WRITE_C_STRING(str, pcf);
1506 SXE_MUTEX_UNLOCK(&ffij->mtx);
1511 finish_ffi_job_data(ffi_job_t ffij)
1513 SXE_MUTEX_LOCK(&ffij->mtx);
1514 xfree(ffij->fof_args);
1515 xfree(ffij->sntnl_args);
1516 SXE_MUTEX_UNLOCK(&ffij->mtx);
1517 SXE_MUTEX_FINI(&ffij->mtx);
1519 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1524 finish_ffi_job(worker_job_t job)
1528 lock_worker_job(job);
1529 ffij = ffi_job(job);
1532 finish_ffi_job_data(ffij);
1534 worker_job_data(job) = NULL;
1535 unlock_worker_job(job);
1540 ffi_job_handle(worker_job_t job)
1543 /* usually called from aux threads */
1545 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1546 int nargs, ret = -1;
1548 lock_worker_job(job);
1549 ffij = ffi_job(job);
1550 unlock_worker_job(job);
1551 SXE_MUTEX_LOCK(&ffij->mtx);
1553 nargs = ffij->fof_nargs;
1554 args = ffij->fof_args;
1555 SXE_MUTEX_UNLOCK(&ffij->mtx);
1557 /* can't ... Fmake_ffi_object is not mt-safe */
1558 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1559 retfo = ffij->retfo;
1562 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1563 #endif /* HAVE_LIBFFI */
1565 SXE_MUTEX_LOCK(&ffij->mtx);
1566 ffij->result = retfo;
1567 SXE_MUTEX_UNLOCK(&ffij->mtx);
1570 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1575 ffi_job_finished(worker_job_t job)
1577 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1580 /* called from main thread */
1581 exec_sentinel(job, ffi_job(job));
1585 static struct work_handler_s ffi_job_handler = {
1586 mark_ffi_job, print_ffi_job, finish_ffi_job,
1587 ffi_job_handle, NULL, ffi_job_finished
1591 make_ffi_asyneq_job(ffi_job_t ffij)
1593 /* create a job digestible by the asyneq */
1594 Lisp_Object job = Qnil;
1595 struct gcpro gcpro1;
1598 job = wrap_object(make_worker_job(&ffi_job_handler));
1599 XWORKER_JOB_DATA(job) = ffij;
1600 /* the scratch buffer thingie */
1605 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1606 Call a function referred to by FO with arguments ARGS asynchronously,
1607 return a job object.
1609 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1611 FO should be a foreign binding initiated by `ffi-defun'.
1612 FO-ARGS should be exactly as many foreign data objects as FO needs.
1613 SENTINEL is a lisp sentinel function called when the job finished,
1614 the function should take at least one argument JOB, further arguments
1615 may be specified by passing further SENTINEL-ARGS.
1617 (int nargs, Lisp_Object *args))
1619 Lisp_Object job = Qnil;
1620 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1621 int sntnl_nargs, fof_nargs;
1623 struct gcpro gcpro1, gcpro2;
1625 CHECK_EFFIO(args[0]);
1626 GCPRO1n(job, args, nargs);
1629 /* determine how many args belong to the fof */
1630 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1631 fof_args = &args[1];
1633 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1634 sntnl = args[fof_nargs+1];
1635 sntnl_args = &args[fof_nargs+2];
1641 /* create the job data object */
1642 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1643 sntnl, sntnl_nargs, sntnl_args);
1644 /* now prepare the job to dispatch */
1645 job = make_ffi_asyneq_job(ffij);
1646 /* ... and dispatch it, change its state to queued */
1647 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1648 eq_enqueue(delegate_eq, job);
1649 /* brag about new jobs in the queue */
1650 eq_queue_trigger_all(delegate_eq);
1655 #endif /* EF_USE_ASYNEQ */
1657 extern struct device *decode_x_device(Lisp_Object device);
1659 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1660 Return DEVICE display as FFI object.
1667 fo = Fmake_ffi_object(Q_pointer, Qnil);
1668 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1669 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1677 #define FFI_CC_CDECL 0
1679 #if defined __i386__
1681 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1683 Lisp_Object fun, alist = Qnil, retlo, foret;
1684 Lisp_Object rtype, argtypes;
1685 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1688 fun = Fcar(cbk_info);
1689 rtype = Fcar(Fcdr(cbk_info));
1690 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1692 CHECK_LIST(argtypes);
1694 arg_buffer += 4; /* Skip return address */
1695 while (!NILP(argtypes)) {
1696 Lisp_Object result, ctype;
1699 ctype = ffi_canonicalise_type(XCAR(argtypes));
1700 size = XINT(Fffi_size_of_type(ctype));
1701 if (EQ(ctype, Q_c_string)) {
1702 char *aptr = *(char**)arg_buffer;
1704 result = ffi_fetch_foreign(aptr, ctype);
1708 result = ffi_fetch_foreign(arg_buffer, ctype);
1709 /* Apply translators and put the result into alist */
1710 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1711 list2(result, XCAR(argtypes)));
1712 alist = Fcons(result, alist);
1715 int sp = (size + mask) & ~mask;
1718 argtypes = XCDR(argtypes);
1720 alist = Fnreverse(alist);
1722 /* Special case, we have no return value */
1723 if (EQ(rtype, Q_void)) {
1724 GCPRO3(fun, alist, rtype);
1730 GCPRO5(fun, alist, rtype, retlo, foret);
1731 retlo = apply1(fun, alist);
1732 foret = Fmake_ffi_object(rtype, Qnil);
1733 Fffi_store(foret, make_int(0), rtype, retlo);
1734 ptr = (void*)XEFFIO(foret)->fop.ptr;
1735 if (EQ(rtype, Q_double)) {
1738 asm volatile ("fldl (%0)" :: "a" (ptr));
1741 } else if (EQ(rtype, Q_float)) {
1744 asm volatile ("flds (%0)" :: "a" (ptr));
1750 if (EQ(rtype, Q_byte) || EQ(rtype, Q_char))
1752 else if (EQ(rtype, Q_unsigned_byte) || EQ(rtype, Q_unsigned_char))
1753 iv = *(char unsigned*)ptr;
1754 else if (EQ(rtype, Q_short))
1756 else if (EQ(rtype, Q_unsigned_short))
1757 iv = *(unsigned short*)ptr;
1762 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1769 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1773 * pushl <data> 68 <addr32>
1774 * call ffi_callback_call_x86 E8 <disp32>
1782 char *buf = xmalloc(sizeof(char)*16);
1783 *(char*) (buf+0) = 0x54;
1784 *(char*) (buf+1) = 0x68;
1785 *(long*) (buf+2) = (long)data;
1786 *(char*) (buf+6) = 0xE8;
1787 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1788 *(char*) (buf+11) = 0x59;
1789 *(char*) (buf+12) = 0x59;
1790 if (cc_type == FFI_CC_CDECL) {
1791 *(char*) (buf+13) = 0xc3;
1792 *(short*)(buf+14) = 0x9090;
1794 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1798 CHECK_CONS(arg_types);
1800 while (!NILP(arg_types)) {
1801 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1802 byte_size += ((sz+mask)&(~mask));
1803 arg_types = XCDR(arg_types);
1806 *(char*) (buf+13) = 0xc2;
1807 *(short*)(buf+14) = (short)byte_size;
1812 #endif /* __i386__ */
1814 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1815 Create dynamic callback and return pointer to it.
1817 (fun, rtype, argtypes, cctype))
1824 data = list3(fun, rtype, argtypes);
1825 /* Put data as property of the fun, so it(data) wont be GCed */
1826 Fput(fun, Q_ffi_callback, data);
1827 ptr = Fmake_ffi_object(Q_pointer, Qnil);
1829 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1830 #endif /* __i386__ */
1837 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1839 defsymbol(&Q_byte, "byte");
1840 defsymbol(&Q_unsigned_byte, "unsigned-byte");
1841 defsymbol(&Q_char, "char");
1842 defsymbol(&Q_unsigned_char, "unsigned-char");
1843 defsymbol(&Q_short, "short");
1844 defsymbol(&Q_unsigned_short, "unsigned-short");
1845 defsymbol(&Q_int, "int");
1846 defsymbol(&Q_unsigned_int, "unsigned-int");
1847 defsymbol(&Q_long, "long");
1848 defsymbol(&Q_unsigned_long, "unsigned-long");
1849 defsymbol(&Q_float, "float");
1850 defsymbol(&Q_double, "double");
1851 defsymbol(&Q_void, "void");
1852 defsymbol(&Q_pointer, "pointer");
1853 defsymbol(&Q_struct, "struct");
1854 defsymbol(&Q_union, "union");
1855 defsymbol(&Q_array, "array");
1856 defsymbol(&Q_function, "function");
1857 defsymbol(&Q_c_string, "c-string");
1858 defsymbol(&Q_c_data, "c-data");
1860 defsymbol(&Qffiobjectp, "ffiobjectp");
1862 defsymbol(&Qffi_translate_to_foreign, "ffi-translate-to-foreign");
1863 defsymbol(&Qffi_translate_from_foreign, "ffi-translate-from-foreign");
1865 defsymbol(&Q_ffi_callback, "ffi-callback");
1867 DEFSUBR(Fffi_basic_type_p);
1868 DEFSUBR(Fffi_canonicalise_type);
1869 DEFSUBR(Fffi_size_of_type);
1870 DEFSUBR(Fmake_ffi_object);
1871 DEFSUBR(Fffi_object_p);
1872 DEFSUBR(Fffi_make_pointer);
1873 DEFSUBR(Fffi_object_address);
1874 DEFSUBR(Fffi_object_canonical_type);
1875 DEFSUBR(Fffi_object_type);
1876 DEFSUBR(Fffi_object_size);
1877 DEFSUBR(Fffi_set_storage_size);
1878 DEFSUBR(Fffi_set_object_type);
1879 DEFSUBR(Fffi_fetch);
1881 DEFSUBR(Fffi_store);
1883 DEFSUBR(Fffi_address_of);
1884 DEFSUBR(Fffi_type_alignment);
1885 DEFSUBR(Fffi_slot_offset);
1886 DEFSUBR(Fffi_load_library);
1888 DEFSUBR(Fffi_dlerror);
1889 DEFSUBR(Fffi_defun);
1890 DEFSUBR(Fffi_call_function);
1892 DEFSUBR(Fffi_lisp_object_to_pointer);
1893 DEFSUBR(Fffi_pointer_to_lisp_object);
1894 DEFSUBR(Fffi_plist);
1896 #ifdef EF_USE_ASYNEQ
1897 DEFSUBR(Fffi_call_functionX);
1898 defsymbol(&Qffi_jobp, "ffi-job-p");
1901 DEFSUBR(Fx_device_display);
1903 DEFSUBR(Fffi_make_callback);
1907 reinit_vars_of_ffi(void)
1909 staticpro_nodump(&Vffi_all_objects);
1910 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1916 reinit_vars_of_ffi();
1918 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1919 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1921 Vffi_named_types = Qnil;
1923 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1924 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1926 Vffi_loaded_libraries = Qnil;
1928 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1929 Function to call when the validity of an FFI type shall be checked.
1931 Vffi_type_checker = intern("ffi-type-p");