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/>. */
33 # include "mule/file-coding.h"
39 #endif /* HAVE_LIBFFI */
42 # include "events/workers.h"
43 # include "events/worker-asyneq.h"
44 #endif /* EF_USE_ASYNEQ */
46 /* For `x-device-display' */
47 #include "ui/X11/console-x.h"
48 #include "ui/device.h"
50 #define EFFI_CODING Qnative
53 * Some compatibility for XEmacs
56 # define SIGNAL_ERROR signal_error
57 # define FFIBYTE Bufbyte
58 # define WRITE_C_STRING(x,y) write_c_string((x),(y))
59 # define WRITE_FMT_STRING(x,y,...) write_fmt_string((x),(y),__VA_ARGS__)
60 # define LRECORD_DESCRIPTION lrecord_description
62 # define SIGNAL_ERROR Fsignal
63 # define FFIBYTE Ibyte
64 # define WRITE_C_STRING(x,y) write_c_string((y),(x))
65 # define WRITE_FMT_STRING(x,y,...) \
68 int wcss = snprintf(wcsb, sizeof(wcsb), \
70 write_c_string((y),wcsb); \
72 # define LRECORD_DESCRIPTION memory_description
77 * byte, ubyte, char, uchar,
78 * short, ushort, int, uint,
81 * void, pointer, c-string
85 * (function RET-TYPE IN-TYPE .. IN-TYPE)
91 * Structures and unions types:
101 * pointer or (pointer TYPE)
104 /* Foreign types, not defined as symbols elsewhere. */
105 Lisp_Object Qarray, Qbyte, Qc_data, Qc_string, Qdouble, Qlong, Qstruct;
106 Lisp_Object Qunion, Qunsigned_byte, Qunsigned_char, Qunsigned_int;
107 Lisp_Object Qunsigned_long, Qunsigned_short;
109 #define FFI_POINTERP(type) (EQ(type, Qpointer) \
110 || (CONSP(type) && EQ(XCAR(type), Qpointer)))
112 #define FFI_TPTR(type) (EQ(type, Qc_string) \
113 || EQ(type, Qc_data) \
114 || FFI_POINTERP(type) \
115 || (CONSP(type) && ((EQ(XCAR(type), Qc_data)) \
116 || EQ(XCAR(type), Qarray))))
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 Qffi_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);
146 escapeflag = escapeflag; /* shutup compiler */
147 if (print_readably) {
149 error("printing unreadable object #<ffiobject 0x%x>",
152 signal_ferror(Qinternal_error,
153 "printing unreadable object #<ffiobject 0x%x>",
157 WRITE_C_STRING("#<ffiobject ", printcharfun);
158 /* Print FFIO type */
159 if (!NILP(ffio->type)) {
160 WRITE_C_STRING("type=", printcharfun);
161 print_internal(ffio->type, printcharfun, 1);
162 WRITE_C_STRING(" ", printcharfun);
164 WRITE_FMT_STRING(printcharfun,"size=%ld fotype=%d foptr=%p>",
165 (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
168 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
169 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
170 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
171 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
172 {XD_INT, offsetof(Lisp_EffiObject, fotype)},
173 {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
175 {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
177 {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
183 ffi_getprop(Lisp_Object fo, Lisp_Object property)
185 return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
189 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
191 external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
196 ffi_remprop(Lisp_Object fo, Lisp_Object property)
198 return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
203 sizeof_ffiobject(const void *header)
205 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
206 return (sizeof(Lisp_EffiObject) + effio->storage_size);
210 sizeof_ffiobject(const void *header)
212 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
213 return (sizeof(Lisp_EffiObject) + effio->storage_size);
217 /* Define ffiobject implementation */
218 const struct lrecord_implementation lrecord_ffiobject = {
220 .marker = mark_ffiobject,
221 .printer = print_ffiobject,
225 .description = ffiobject_description,
226 .getprop = ffi_getprop,
227 .putprop = ffi_putprop,
228 .remprop = ffi_remprop,
231 .size_in_bytes_method = sizeof_ffiobject,
232 .lrecord_type_index = lrecord_type_ffiobject,
237 /** alignment in union and structures **/
241 * - An entire structure or union is aligned on the same boundary as
242 * its most strictly aligned member.
244 * - Each member is assigned to the lowest available offset with the
245 * appropriate alignment. This may require /internal padding/,
246 * depending on the previous member.
248 * - A structure's size is increased, if necessary, to make it a
249 * multiple of the alignment. This may require /tail padding/,
250 * depending on the last member.
255 * char c; .-------2+---1+---0.
256 * short s; | s |pad | c |
257 * } `--------+----+----'
259 * Internal and Tail padding:
261 * struct { .------------1+---0.
262 * char c; | pad | c |
263 * double d; |-------------+---4|
265 * } |-----------------8|
267 * |------14+-------12|
269 * `--------+---------'
273 * union { .------------1+---0.
274 * char c; | pad | c |
275 * short s; |-------2+----+---0|
277 * } |--------+--------0|
279 * `------------------'
282 ffi_check_type(Lisp_Object type)
284 return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
287 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
288 Return non-nil if TYPE is a basic FFI type.
290 A type is said to be basic, if it is neither a pointer nor a
291 function, and there is a corresponding built-in type in C.
295 if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte) || EQ(type, Qchar)
296 || EQ(type, Qunsigned_char) || EQ(type, Qshort)
297 || EQ(type, Qunsigned_short) || EQ(type, Qint)
298 || EQ(type, Qunsigned_int) || EQ(type, Qlong)
299 || EQ(type, Qunsigned_long) || EQ(type, Qfloat)
300 || EQ(type, Qdouble) || EQ(type, Qvoid)
301 || EQ(type, Qc_string) || EQ(type, Qc_data)
302 || (CONSP(type) && EQ(XCAR(type), Qc_data)))
310 ffi_canonicalise_type(Lisp_Object type)
312 /* this function canNOT GC */
314 while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
315 if EQ(type, Qpointer)
317 type = Fcdr(Fassq(type, Vffi_named_types));
323 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
324 Return FFI type TYPE in a canonical form.
328 Lisp_Object canon_type = ffi_canonicalise_type(type);
329 if (NILP(canon_type)) {
331 signal_simple_error("No such FFI type", type);
333 signal_error(Qinternal_error, "No such FFI type", type);
339 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0, /*
340 Return the size of the foreign type TYPE.
342 Valid foreign types are: `byte', `unsigned-byte', `char',
343 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
344 `long', `unsigned-long', `pointer', `float', `double',
345 `object', and `c-string'.
351 type = ffi_canonicalise_type(type);
354 else if (EQ(type, Qbyte))
355 tsize = sizeof(int8_t);
356 else if (EQ(type, Qunsigned_byte))
357 tsize = sizeof(uint8_t);
358 else if (EQ(type, Qchar))
359 tsize = sizeof(char);
360 else if (EQ(type, Qunsigned_char))
361 tsize = sizeof(unsigned char);
362 else if (EQ(type, Qshort))
363 tsize = sizeof(short);
364 else if (EQ(type, Qunsigned_short))
365 tsize = sizeof(unsigned short);
366 else if (EQ(type, Qint))
368 else if (EQ(type, Qunsigned_int))
369 tsize = sizeof(unsigned int);
370 else if (EQ(type, Qlong))
371 tsize = sizeof(long);
372 else if (EQ(type, Qunsigned_long))
373 tsize = sizeof(unsigned long);
374 else if (EQ(type, Qfloat))
375 tsize = sizeof(float);
376 else if (EQ(type, Qdouble))
377 tsize = sizeof(double);
378 else if (EQ(type, Qc_string))
379 tsize = sizeof(char *);
380 else if (FFI_POINTERP(type))
381 tsize = sizeof(void *);
382 else if (EQ(type, Qc_data))
383 tsize = sizeof(void *);
384 else if (CONSP(type) && EQ(XCAR(type), Qc_data)) {
385 Lisp_Object cdsize = XCDR(type);
387 tsize = XINT(cdsize);
388 } else if (CONSP(type) && EQ(XCAR(type), Qfunction))
389 tsize = sizeof(void(*));
390 else if (CONSP(type) && EQ(XCAR(type), Qarray)) {
391 Lisp_Object atype = Fcar(XCDR(type));
392 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
395 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
396 } else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
397 return Fffi_slot_offset(type, Qnil);
398 } else if (CONSP(type) && EQ(XCAR(type), Qunion)) {
399 Lisp_Object slots = Fcdr(XCDR(type));
404 while (!NILP(slots)) {
405 Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
406 int slot_size = XINT(Fffi_size_of_type(slot_type));
407 if (slot_size > tsize)
413 signal_simple_error("Unrecognized foreign type", type);
415 signal_error(Qinternal_error, "Unrecognized foreign type", type);
419 return make_int(tsize);
422 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
423 Create a new FFI object of type TYPE.
424 If optional argument SIZE is non-nil it should be an
425 integer, in this case additional storage size to hold data
426 of at least length SIZE is allocated.
432 Lisp_Object result = Qnil;
433 Lisp_EffiObject *ffio;
438 /* NOTE: ffi_check_type returns canonical type */
439 ctype = ffi_check_type(type);
441 size = Fffi_size_of_type(type);
444 if (CONSP(ctype) && EQ(XCAR(ctype), Qc_data) && INTP(XCDR(ctype)))
447 cs_or_cd = EQ(ctype, Qc_string) || (EQ(ctype, Qc_data));
448 if ((cs_or_cd && (XINT(size) < 1))
449 || (!(cs_or_cd || FFI_POINTERP(ctype))
450 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
452 signal_simple_error("storage size too small to store type",
455 ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
457 XSETEFFIO(result, ffio);
459 signal_error(Qinternal_error,
460 "storage size too small to store type",
463 ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
465 result = wrap_effio(ffio);
468 ffio->size = Fffi_size_of_type(type);
472 /* Initialize foreign pointer */
473 ffio->fotype = EFFI_FOT_NONE;
474 ffio->storage_size = XINT(size);
475 ffio->fop.ptr = ffio->fostorage;
477 if (!NILP(Vffi_all_objects))
478 XWEAK_LIST_LIST(Vffi_all_objects) =
479 Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
481 RETURN_UNGCPRO(result);
484 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
485 Return non-nil if FO is an FFI object, nil otherwise.
489 return (EFFIOP(fo) ? Qt : Qnil);
492 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
493 Return the address FO points to.
498 return make_float((long)XEFFIO(fo)->fop.ptr);
501 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
502 "Return a pointer pointing to ADDRESS."
510 addr = XINT(address);
511 else if (FLOATP(address))
512 addr = XFLOATINT(address);
515 signal_simple_error("FFI: invalid address type", address);
517 signal_error(Qinternal_error, "FFI: invalid address type",
522 ptr = Fmake_ffi_object(Qpointer, Qnil);
523 XEFFIO(ptr)->fop.ptr = (void*)addr;
527 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
528 Return FO's real type, that is after resolving user defined types.
533 return ffi_canonicalise_type(XEFFIO(fo)->type);
536 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
542 return (XEFFIO(fo)->type);
545 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
546 Cast FO to type TYPE and reassign the cast value.
547 Return casted foreign object.
553 ffi_check_type(type);
554 XEFFIO(fo)->type = type;
559 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
560 Return the size of the allocated space of FO.
565 return (XEFFIO(fo)->size);
568 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
569 Set the size of the allocated space of FO.
575 XEFFIO(fo)->storage_size = XUINT(size);
579 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
580 Load library LIBNAME and return a foreign object handle if successful,
581 or `nil' if the library cannot be loaded.
583 The argument LIBNAME should be the file-name string of a shared object
584 library. Normally you should omit the file extension, as this
585 function will add the appripriate extension for the current platform
588 The library should reside in one of the directories specified by the
589 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
594 #ifdef LTDL_SHLIB_EXT
595 # define EXT LTDL_SHLIB_EXT
596 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
597 # define EXT ".dylib"
600 #endif /* LTDL_SHLIB_EXT */
602 void *handler, *dotpos;
603 Lisp_Object fo = Qnil;
604 Lisp_EffiObject *ffio;
608 CHECK_STRING(libname);
610 /* Add an extension if we need to */
611 dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
612 if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
613 ssize_t liblen = XSTRING_LENGTH(libname);
614 ssize_t soname_len = liblen + sizeof(EXT) + 1;
615 soname = xmalloc( soname_len);
616 xstrncpy(soname, (char *)XSTRING_DATA(libname), soname_len);
617 xstrncpy(soname+liblen, EXT, soname_len-liblen);
620 if ( soname == NULL ) {
621 handler = dlopen((const char *)XSTRING_DATA(libname),
622 RTLD_GLOBAL|RTLD_NOW);
624 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
632 fo = Fmake_ffi_object(Qpointer, Qnil);
635 ffio->fotype = EFFI_FOT_BIND;
636 ffio->fop.ptr = handler;
641 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
642 Make and return a foreign object of type TYPE and bind it to the
645 The argument TYPE can be any type-cell.
646 The argument SYM should be a string naming an arbitrary symbol
647 in one of the loaded libraries.
649 If SYM does not exist in any of the loaded libraries, `nil' is
654 Lisp_Object fo = Qnil;
655 Lisp_EffiObject *ffio;
658 ffi_check_type(type);
662 fo = Fmake_ffi_object(type, Qnil);
664 ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
665 if (ffio->fop.ptr == NULL) {
670 ffio->fotype = EFFI_FOT_BIND;
675 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
676 Return dl error string.
680 const char *dles = dlerror();
682 if (LIKELY(dles != NULL)) {
683 size_t sz = strlen(dles);
684 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
690 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
691 Make and return a foreign object of type TYPE and bind it to the
694 The argument TYPE should be a function type-cell.
695 The argument SYM should be a string naming a function in one of
696 the loaded libraries.
698 If SYM does not exist in any of the loaded libraries, an error
701 This is like `ffi-bind' but for function objects.
705 Lisp_Object fo = Qnil;
706 Lisp_EffiObject *ffio;
709 ffi_check_type(type);
714 fo = Fmake_ffi_object(type, Qnil);
716 ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
717 if (ffio->fop.fun == NULL) {
719 signal_simple_error("Can't define function", sym);
721 signal_error(Qinternal_error, "Can't define function", sym);
725 ffio->fotype = EFFI_FOT_FUNC;
731 * Return alignment policy for struct or union FFI_SU.
732 * x86: Return 1, 2 or 4.
733 * x86_64: Return 1, 2, 4 or 8
734 * mips: Return 1, 2, 4 or 8.
737 ffi_type_align(Lisp_Object type)
739 type = ffi_canonicalise_type(type);
741 if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte)
742 || EQ(type, Qchar) || EQ(type, Qunsigned_char))
744 if (EQ(type, Qshort) || EQ(type, Qunsigned_short))
747 if (EQ(type, Qlong) || EQ(type, Qunsigned_long)
748 || EQ(type, Qdouble))
750 #endif /* __x86_64__ */
753 if (EQ(type, Qdouble))
755 #endif /* FFI_MIPS */
759 } else if (FFI_TPTR(type)) {
761 #endif /* __x86_64__ */
762 } else if (CONSP(type)
763 && (EQ(XCAR(type), Qstruct) || EQ(XCAR(type), Qunion))) {
766 for (al = 0, type = Fcdr(Fcdr(type));
770 Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
771 int tmp_al = ffi_type_align(stype);
783 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
784 Return TYPE alignment.
788 return make_int(ffi_type_align(type));
791 #define EFFI_ALIGN_OFF(off, a) (((off) + ((a)-1)) & ~((a)-1))
793 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
794 Return the offset of SLOT in TYPE.
795 SLOT can be either a valid (named) slot in TYPE or `nil'.
796 If SLOT is `nil' return the size of the struct.
803 type = ffi_canonicalise_type(type);
806 error("Not struct or union");
808 Fsignal(Qwrong_type_argument,
809 list2(Qstringp, build_string("Not struct or union")));
813 slots = Fcdr(XCDR(type));
815 while (!NILP(slots)) {
816 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
818 retoff = EFFI_ALIGN_OFF(retoff, ffi_type_align(tmp_slot));
819 if (EQ(XCAR(XCAR(slots)), slot)) {
821 /* TODO: add support for :offset keyword in SLOT */
825 retoff += XINT(Fffi_size_of_type(tmp_slot));
829 if (NILP(slots) && !NILP(slot)) {
831 signal_simple_error("FFI: Slot not found", slot);
833 signal_error(Qinternal_error, "FFI: Slot not found", slot);
836 return make_int(retoff);
840 * TYPE must be already canonicalised
843 ffi_fetch_foreign(void *ptr, Lisp_Object type)
845 /* this function canNOT GC */
846 Lisp_Object retval = Qnone;
849 retval = make_char(*(char*)ptr);
850 else if (EQ(type, Qunsigned_char))
851 retval = make_char(*(char unsigned*)ptr);
852 else if (EQ(type, Qbyte))
853 retval = make_int(*(char*)ptr);
854 else if (EQ(type, Qunsigned_byte))
855 retval = make_int(*(unsigned char*)ptr);
856 else if (EQ(type, Qshort))
857 retval = make_int(*(short*)ptr);
858 else if (EQ(type, Qunsigned_short))
859 retval = make_int(*(unsigned short*)ptr);
860 else if (EQ(type, Qint))
861 retval = make_int(*(int*)ptr);
862 else if (EQ(type, Qunsigned_int))
863 retval = make_int(*(unsigned int*)ptr);
864 else if (EQ(type, Qlong))
865 retval = make_int(*(long*)ptr);
866 else if (EQ(type, Qunsigned_long))
867 retval = make_int(*(unsigned long*)ptr);
868 else if (EQ(type, Qfloat))
869 retval = make_float(*(float*)ptr);
870 else if (EQ(type, Qdouble))
871 retval = make_float(*(double*)ptr);
872 else if (EQ(type, Qc_string)) {
873 retval = build_ext_string((char*)ptr, Qbinary);
874 } else if (EQ(type, Qvoid)) {
876 } else if (FFI_POINTERP(type)) {
877 retval = Fmake_ffi_object(type, Qnil);
878 XEFFIO(retval)->fop.ptr = *(void**)ptr;
879 } else if (CONSP(type) && EQ(XCAR(type), Qfunction)) {
880 retval = Fmake_ffi_object(type, Qnil);
881 XEFFIO(retval)->fop.fun = (void*)ptr;
882 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
888 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
889 Fetch value from the foreign object FO from OFFSET position.
890 TYPE specifies value for data to be fetched.
894 Lisp_Object origtype = type;
895 Lisp_Object retval = Qnil;
896 Lisp_EffiObject *ffio;
904 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
906 type = ffi_canonicalise_type(type);
909 /* Fetch value and translate it according to translators */
910 retval = ffi_fetch_foreign(ptr, type);
911 if (EQ(retval, Qnone)) {
912 /* Special case for c-data */
913 if (EQ(type, Qc_data) ||
914 (CONSP(type) && EQ(XCAR(type), Qc_data)))
917 if (EQ(type, Qc_data)) {
918 tlen = ffio->storage_size - XINT(offset);
920 CHECK_INT(XCDR(type));
921 tlen = XUINT(XCDR(type));
924 retval = make_ext_string(ptr, tlen, Qbinary);
927 signal_simple_error("Can't fetch for this type", origtype);
929 signal_error(Qinternal_error, "Can't fetch for this type",
934 retval = apply1(Findirect_function(Qffi_translate_from_foreign),
935 list2(retval, origtype));
937 RETURN_UNGCPRO(retval);
940 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
941 Return the element of FARRAY at index IDX (starting with 0).
950 type = ffi_canonicalise_type(XEFFIO(farray)->type);
951 if (!FFI_TPTR(type)) {
953 signal_simple_error("Not an array type", type);
955 signal_error(Qinternal_error, "Not an array type", type);
958 if (EQ(type, Qc_string))
961 type = Fcar(XCDR(type));
963 return Fffi_fetch(farray,
964 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
968 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
969 For foreign object FO at specified OFFSET store data.
970 Type of data is specified by VAL-TYPE and data itself specified in VAL.
972 VAL-TYPE can be either a basic FFI type or an FFI pointer.
973 If VAL-TYPE is a basic FFI type, then VAL can be an
974 ordinary, but suitable Emacs lisp object.
975 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
976 object of the underlying type pointed to.
978 (fo, offset, val_type, val))
980 Lisp_Object origtype = val_type;
981 Lisp_EffiObject *ffio;
988 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
990 val_type = ffi_canonicalise_type(val_type);
992 /* Translate value */
993 val = apply1(Findirect_function(Qffi_translate_to_foreign),
994 list2(val, origtype));
996 if (EQ(val_type, Qchar) || EQ(val_type, Qunsigned_char)) {
998 SIGNAL_ERROR(Qwrong_type_argument,
999 list2(Qcharacterp, val));
1001 *(char*)ptr = XCHAR(val);
1002 } else if (EQ(val_type, Qbyte) || EQ(val_type, Qunsigned_byte)) {
1004 SIGNAL_ERROR(Qwrong_type_argument,
1005 list2(Qintegerp, val));
1007 *(char*)ptr = XINT(val);
1008 } else if (EQ(val_type, Qshort) || EQ(val_type, Qunsigned_short)) {
1010 SIGNAL_ERROR(Qwrong_type_argument,
1011 list2(Qintegerp, val));
1013 *(short*)ptr = (short)XINT(val);
1014 } else if (EQ(val_type, Qint) || EQ(val_type, Qunsigned_int)) {
1016 *(int*)ptr = XINT(val);
1017 } else if (FLOATP(val)) {
1018 fpfloat tmp = XFLOATINT(val);
1019 *(int*)ptr = (int)tmp;
1021 SIGNAL_ERROR(Qwrong_type_argument,
1022 list2(Qfloatp, val));
1024 } else if (EQ(val_type, Qlong) || EQ(val_type, Qunsigned_long)) {
1026 *(long*)ptr = (long)XINT(val);
1027 } else if (FLOATP(val)) {
1028 fpfloat tmp = XFLOATINT(val);
1029 *(long*)ptr = (long int)tmp;
1031 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1033 } else if (EQ(val_type, Qfloat)) {
1035 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1036 *(float*)ptr = XFLOATINT(val);
1037 } else if (EQ(val_type, Qdouble)) {
1039 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1040 *(double*)ptr = XFLOAT_DATA(val);
1041 } else if (EQ(val_type, Qc_string)) {
1045 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1047 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1048 ALLOCA, (tmp, tmplen), Qnil);
1049 if ( tmp != NULL ) {
1050 memcpy((char*)ptr, tmp, tmplen + 1);
1054 (const char *)XSTRING_DATA(val),
1055 XSTRING_LENGTH(val) + 1);
1057 } else if (EQ(val_type, Qc_data) ||
1059 EQ(XCAR(val_type), Qc_data) && INTP(XCDR(val_type)))) {
1060 char *val_ext = NULL;
1061 unsigned int val_ext_len;
1063 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1065 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1066 (val_ext, val_ext_len), Qbinary);
1067 if (val_ext == NULL ||
1068 (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type))))) {
1070 error("storage size too small");
1072 Fsignal(Qrange_error,
1074 build_string("storage size too small")));
1075 #endif /* SXEMACS */
1077 memcpy((char*)ptr, (const char *)val_ext, val_ext_len);
1079 } else if (FFI_POINTERP(val_type)) {
1082 signal_simple_error("FFI: Value not of pointer type", \
1083 list2(origtype, val));
1085 Fsignal(Qwrong_type_argument,
1086 list2(Qstringp, build_string("type")));
1087 #endif /* SXEMACS */
1089 *(void**)ptr = (void*)XEFFIO(val)->fop.ptr;
1090 } else if (CONSP(val_type) && EQ(XCAR(val_type), Qstruct)) {
1093 signal_simple_error("FFI: Value not FFI object", \
1094 list2(origtype, val));
1096 Fsignal(Qwrong_type_argument,
1097 list2(Qstringp, build_string("type")));
1098 #endif /* SXEMACS */
1100 memcpy((char*)ptr, (const char *)XEFFIO(val)->fop.ptr, \
1101 XINT(Fffi_size_of_type(val_type)));
1104 signal_simple_error("FFI: Non basic or pointer type", origtype);
1106 Fsignal(Qinternal_error,
1108 build_string("non basic or pointer type")));
1109 #endif /* SXEMACS */
1115 DEFUN("ffi-aset", Fffi_aset, 3, 3, 0, /*
1116 Store the element VALUE in FARRAY at index IDX (starting with 0).
1118 (farray, idx, value))
1122 CHECK_EFFIO(farray);
1125 type = ffi_canonicalise_type(XEFFIO(farray)->type);
1126 if (!FFI_TPTR(type)) {
1128 signal_simple_error("Not an array type", type);
1130 signal_error(Qinternal_error, "Not an array type", type);
1131 #endif /* SXEMACS */
1133 if (EQ(type, Qc_string))
1136 type = Fcar(XCDR(type));
1138 return Fffi_store(farray,
1139 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
1143 DEFUN("ffi-address-of", Fffi_address_of, 1, 1, 0, /*
1144 Return the FFI object that stores the address of given FFI object FO.
1146 This is the equivalent of the `&' operator in C.
1150 Lisp_Object newfo = Qnil;
1151 Lisp_EffiObject *ffio, *newffio;
1152 struct gcpro gcpro1;
1158 newfo = Fmake_ffi_object(Qpointer, Qnil);
1159 newffio = XEFFIO(newfo);
1161 newffio->fotype = EFFI_FOT_BIND;
1162 if (FFI_TPTR(ffio->type))
1163 newffio->fop.ptr = (void*)&ffio->fop.ptr;
1165 newffio->fop.ptr = ffio->fop.ptr;
1167 RETURN_UNGCPRO(newfo);
1170 DEFUN("ffi-lisp-object-to-pointer", Fffi_lisp_object_to_pointer, 1, 1, 0, /*
1171 Convert lisp object to FFI pointer.
1175 Lisp_Object newfo = Qnil;
1176 Lisp_EffiObject *newffio;
1177 struct gcpro gcpro1;
1181 newfo = Fmake_ffi_object(Qpointer, Qnil);
1182 newffio = XEFFIO(newfo);
1183 newffio->fotype = EFFI_FOT_BIND;
1184 newffio->fop.ptr = (void*)obj;
1186 /* Hold a reference to OBJ in NEWFO's plist */
1187 Fput(newfo, intern("lisp-object"), obj);
1189 RETURN_UNGCPRO(newfo);
1192 DEFUN("ffi-pointer-to-lisp-object", Fffi_pointer_to_lisp_object, 1, 1, 0, /*
1193 Convert FFI pointer to lisp object.
1198 return (Lisp_Object)XEFFIO(ptr)->fop.ptr;
1201 DEFUN("ffi-plist", Fffi_plist, 1, 1, 0, /*
1202 Return properties list for FFI object FO.
1207 return (XEFFIO(fo)->plist);
1212 static int lf_cindex = 0;
1216 * This will work in most cases.
1217 * However it might not work for large structures,
1218 * In general we should allocate these spaces dynamically
1220 #define MAX_TYPES_VALUES 1024
1221 /* ex_ffitypes_dummies used for structure types */
1222 static ffi_type ex_ffitypes_dummies[MAX_TYPES_VALUES + 1];
1223 static ffi_type *ex_ffitypes[MAX_TYPES_VALUES + 1];
1224 static void *ex_values[MAX_TYPES_VALUES + 1];
1226 #if SIZEOF_LONG == 4
1227 # define effi_type_ulong ffi_type_uint32
1228 # define effi_type_slong ffi_type_sint32
1229 #elif SIZEOF_LONG == 8
1230 # define effi_type_ulong ffi_type_uint64
1231 # define effi_type_slong ffi_type_sint64
1235 extffi_setup_argument(Lisp_Object type, ffi_type **ft)
1237 type = ffi_canonicalise_type(type);
1238 if (EQ(type, Qchar) || EQ(type, Qbyte))
1239 *ft = &ffi_type_schar;
1240 else if (EQ(type, Qunsigned_char) || EQ(type, Qunsigned_byte))
1241 *ft = &ffi_type_uchar;
1242 else if (EQ(type, Qshort))
1243 *ft = &ffi_type_sshort;
1244 else if (EQ(type, Qunsigned_short))
1245 *ft = &ffi_type_ushort;
1246 else if (EQ(type, Qint))
1247 *ft = &ffi_type_sint;
1248 else if (EQ(type, Qunsigned_int))
1249 *ft = &ffi_type_uint;
1250 else if (EQ(type, Qunsigned_long))
1251 *ft = &effi_type_ulong;
1252 else if (EQ(type, Qlong))
1253 *ft = &effi_type_slong;
1254 else if (EQ(type, Qfloat))
1255 *ft = &ffi_type_float;
1256 else if (EQ(type, Qdouble))
1257 *ft = &ffi_type_double;
1258 else if (EQ(type, Qvoid))
1259 *ft = &ffi_type_void;
1260 else if (FFI_TPTR(type))
1261 *ft = &ffi_type_pointer;
1262 else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
1263 Lisp_Object slots = Fcdr(XCDR(type));
1269 nt_size = XINT(Flength(slots)) + 1;
1270 if (nt_size + lf_cindex > MAX_TYPES_VALUES) {
1271 lf_cindex = 0; /* reset cindex */
1273 error("cindex overflow");
1275 Fsignal(Qoverflow_error,
1277 build_string("cindex overflow")));
1278 #endif /* SXEMACS */
1280 ntypes = &ex_ffitypes[lf_cindex];
1281 *ft = &ex_ffitypes_dummies[lf_cindex];
1283 /* Update lf_cindex in case TYPE struct contains other
1285 lf_cindex += nt_size;
1287 (*ft)->type = FFI_TYPE_STRUCT;
1288 (*ft)->alignment = ffi_type_align(type);
1289 (*ft)->elements = ntypes;
1291 for (i = 0; (i < nt_size) && !NILP(slots); slots = XCDR(slots), i++)
1292 extffi_setup_argument(Fcar(Fcdr(XCAR(slots))), &ntypes[i]);
1296 signal_simple_error("Can't setup argument for type", type);
1298 signal_error(Qinternal_error,
1299 "Can't setup argument for type", type);
1300 #endif /* SXEMACS */
1305 ffi_call_using_libffi(Lisp_Object fo_fun, Lisp_Object ret_fo,
1306 int in_nargs, Lisp_Object *in_args)
1308 Lisp_EffiObject *ffio;
1315 lf_cindex = in_nargs; /* reserve */
1316 for (i = 0; i < in_nargs; i++) {
1317 ffio = XEFFIO(in_args[i]);
1318 fft = Fffi_canonicalise_type(ffio->type);
1319 extffi_setup_argument(fft, &ex_ffitypes[i]);
1321 ex_values[i] = &ffio->fop.ptr;
1323 ex_values[i] = ffio->fop.ptr;
1326 ffio = XEFFIO(ret_fo);
1327 fft = Fffi_canonicalise_type(ffio->type);
1328 extffi_setup_argument(fft, &rtype);
1330 rvalue = &ffio->fop.ptr;
1332 rvalue = ffio->fop.ptr;
1334 if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, in_nargs,
1335 rtype, ex_ffitypes) == FFI_OK)
1337 stop_async_timeouts();
1338 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1340 start_async_timeouts();
1347 #endif /* HAVE_LIBFFI */
1349 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1350 Call a function referred to by FO with arguments ARGS, maybe
1351 return a foreign object with the result or nil if there is
1354 Arguments are: FO &rest FO-ARGS
1356 FO should be a foreign binding initiated by `ffi-defun', and
1357 ARGS should be foreign data objects or pointers to these.
1359 (int nargs, Lisp_Object * args))
1361 Lisp_Object faf = Qnil, retfo = Qnil;
1362 Lisp_EffiObject *ffio;
1364 struct gcpro gcpro1, gcpro2;
1370 retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1373 ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1374 #endif /* HAVE_LIBFFI */
1376 RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1379 #ifdef EF_USE_ASYNEQ
1380 /* handler for asynchronously calling ffi code */
1381 Lisp_Object Qffi_jobp;
1382 #define EFFI_DEBUG_JOB(args...)
1384 exec_sentinel_unwind(Lisp_Object SXE_UNUSED(datum))
1390 exec_sentinel(void *job, ffi_job_t ffij)
1391 __attribute__((always_inline));
1393 exec_sentinel(void *job, ffi_job_t ffij)
1395 /* This function can GC */
1396 /* called from main thread */
1397 int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1398 Lisp_Object funcell[nargs+2];
1399 struct gcpro gcpro1;
1401 funcell[0] = ffij->sntnl;
1402 funcell[1] = (Lisp_Object)job;
1403 for (i = 0; i < nargs; i++) {
1404 funcell[2+i] = ffij->sntnl_args[i];
1406 GCPROn(funcell, nargs+2);
1408 record_unwind_protect(exec_sentinel_unwind, Qnil);
1409 /* call the funcell */
1410 Ffuncall(nargs+2, funcell);
1411 /* reset to previous state */
1412 restore_match_data();
1414 unbind_to(speccount, Qnil);
1418 static inline ffi_job_t
1419 allocate_ffi_job(void)
1421 ffi_job_t ffij = xnew(struct ffi_job_s);
1422 EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1426 static inline ffi_job_t
1427 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1428 Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1430 /* exec'd in the main thread */
1431 ffi_job_t ffij = allocate_ffi_job();
1434 SXE_MUTEX_INIT(&ffij->mtx);
1436 if (fof_nargs > 0) {
1437 ffij->fof_nargs = fof_nargs;
1438 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1439 for (i = 0; i < fof_nargs; i++) {
1440 ffij->fof_args[i] = fof_args[i];
1443 ffij->fof_nargs = 0;
1444 ffij->fof_args = NULL;
1447 ffij->sntnl = sntnl;
1448 if (sntnl_nargs > 0) {
1449 ffij->sntnl_nargs = sntnl_nargs;
1450 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1451 for (i = 0; i < sntnl_nargs; i++) {
1452 ffij->sntnl_args[i] = sntnl_args[i];
1455 ffij->sntnl_nargs = 0;
1456 ffij->sntnl_args = NULL;
1459 ffij->result = Qnil;
1460 ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1465 mark_ffi_job(worker_job_t job)
1467 ffi_job_t ffij = ffi_job(job);
1473 SXE_MUTEX_LOCK(&ffij->mtx);
1474 mark_object(ffij->fof);
1475 for (i = 0; i < ffij->fof_nargs; i++) {
1476 mark_object(ffij->fof_args[i]);
1478 mark_object(ffij->sntnl);
1479 for (i = 0; i < ffij->sntnl_nargs; i++) {
1480 mark_object(ffij->sntnl_args[i]);
1482 mark_object(ffij->retfo);
1483 mark_object(ffij->result);
1484 SXE_MUTEX_UNLOCK(&ffij->mtx);
1489 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1491 ffi_job_t ffij = ffi_job(job);
1493 SXE_MUTEX_LOCK(&ffij->mtx);
1494 WRITE_FMT_STRING(pcf, " carrying #<ffi-job 0x%lx>",
1495 (long unsigned int)ffij);
1496 SXE_MUTEX_UNLOCK(&ffij->mtx);
1501 finish_ffi_job_data(ffi_job_t ffij)
1503 SXE_MUTEX_LOCK(&ffij->mtx);
1504 xfree(ffij->fof_args);
1505 xfree(ffij->sntnl_args);
1506 SXE_MUTEX_UNLOCK(&ffij->mtx);
1507 SXE_MUTEX_FINI(&ffij->mtx);
1509 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1514 finish_ffi_job(worker_job_t job)
1518 lock_worker_job(job);
1519 ffij = ffi_job(job);
1522 finish_ffi_job_data(ffij);
1524 worker_job_data(job) = NULL;
1525 unlock_worker_job(job);
1530 ffi_job_handle(worker_job_t job)
1533 /* usually called from aux threads */
1535 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1536 int nargs, ret = -1;
1538 lock_worker_job(job);
1539 ffij = ffi_job(job);
1540 unlock_worker_job(job);
1541 SXE_MUTEX_LOCK(&ffij->mtx);
1543 nargs = ffij->fof_nargs;
1544 args = ffij->fof_args;
1545 SXE_MUTEX_UNLOCK(&ffij->mtx);
1547 /* can't ... Fmake_ffi_object is not mt-safe */
1548 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1549 retfo = ffij->retfo;
1552 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1553 #endif /* HAVE_LIBFFI */
1555 SXE_MUTEX_LOCK(&ffij->mtx);
1556 ffij->result = retfo;
1557 SXE_MUTEX_UNLOCK(&ffij->mtx);
1560 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1565 ffi_job_finished(worker_job_t job)
1567 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1570 /* called from main thread */
1571 exec_sentinel(job, ffi_job(job));
1575 static struct work_handler_s ffi_job_handler = {
1576 mark_ffi_job, print_ffi_job, finish_ffi_job,
1577 ffi_job_handle, NULL, ffi_job_finished
1581 make_ffi_asyneq_job(ffi_job_t ffij)
1583 /* create a job digestible by the asyneq */
1584 Lisp_Object job = Qnil;
1585 struct gcpro gcpro1;
1588 job = wrap_object(make_worker_job(&ffi_job_handler));
1589 XWORKER_JOB_DATA(job) = ffij;
1590 /* the scratch buffer thingie */
1595 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1596 Call a function referred to by FO with arguments ARGS asynchronously,
1597 return a job object.
1599 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1601 FO should be a foreign binding initiated by `ffi-defun'.
1602 FO-ARGS should be exactly as many foreign data objects as FO needs.
1603 SENTINEL is a lisp sentinel function called when the job finished,
1604 the function should take at least one argument JOB, further arguments
1605 may be specified by passing further SENTINEL-ARGS.
1607 (int nargs, Lisp_Object *args))
1609 Lisp_Object job = Qnil;
1610 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1611 int sntnl_nargs, fof_nargs;
1613 struct gcpro gcpro1, gcpro2;
1615 CHECK_EFFIO(args[0]);
1616 GCPRO1n(job, args, nargs);
1619 /* determine how many args belong to the fof */
1620 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1621 fof_args = &args[1];
1623 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1624 sntnl = args[fof_nargs+1];
1625 sntnl_args = &args[fof_nargs+2];
1631 /* create the job data object */
1632 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1633 sntnl, sntnl_nargs, sntnl_args);
1634 /* now prepare the job to dispatch */
1635 job = make_ffi_asyneq_job(ffij);
1636 /* ... and dispatch it, change its state to queued */
1637 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1638 eq_enqueue(delegate_eq, job);
1639 /* brag about new jobs in the queue */
1640 eq_queue_trigger_all(delegate_eq);
1645 #endif /* EF_USE_ASYNEQ */
1647 extern struct device *decode_x_device(Lisp_Object device);
1649 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1650 Return DEVICE display as FFI object.
1657 fo = Fmake_ffi_object(Qpointer, Qnil);
1658 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1659 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1667 #define FFI_CC_CDECL 0
1669 #if defined __i386__
1671 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1673 Lisp_Object fun, alist = Qnil, retlo, foret;
1674 Lisp_Object rtype, argtypes;
1675 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1678 fun = Fcar(cbk_info);
1679 rtype = Fcar(Fcdr(cbk_info));
1680 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1682 CHECK_LIST(argtypes);
1684 arg_buffer += 4; /* Skip return address */
1685 while (!NILP(argtypes)) {
1686 Lisp_Object result, ctype;
1689 ctype = ffi_canonicalise_type(XCAR(argtypes));
1690 size = XINT(Fffi_size_of_type(ctype));
1691 if (EQ(ctype, Qc_string)) {
1692 char *aptr = *(char**)arg_buffer;
1694 result = ffi_fetch_foreign(aptr, ctype);
1698 result = ffi_fetch_foreign(arg_buffer, ctype);
1699 /* Apply translators and put the result into alist */
1700 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1701 list2(result, XCAR(argtypes)));
1702 alist = Fcons(result, alist);
1705 int sp = (size + mask) & ~mask;
1708 argtypes = XCDR(argtypes);
1710 alist = Fnreverse(alist);
1712 /* Special case, we have no return value */
1713 if (EQ(rtype, Qvoid)) {
1714 GCPRO3(fun, alist, rtype);
1720 GCPRO5(fun, alist, rtype, retlo, foret);
1721 retlo = apply1(fun, alist);
1722 foret = Fmake_ffi_object(rtype, Qnil);
1723 Fffi_store(foret, make_int(0), rtype, retlo);
1724 ptr = (void*)XEFFIO(foret)->fop.ptr;
1725 if (EQ(rtype, Qdouble)) {
1728 asm volatile ("fldl (%0)" :: "a" (ptr));
1731 } else if (EQ(rtype, Qfloat)) {
1734 asm volatile ("flds (%0)" :: "a" (ptr));
1740 if (EQ(rtype, Qbyte) || EQ(rtype, Qchar))
1742 else if (EQ(rtype, Qunsigned_byte) || EQ(rtype, Qunsigned_char))
1743 iv = *(char unsigned*)ptr;
1744 else if (EQ(rtype, Qshort))
1746 else if (EQ(rtype, Qunsigned_short))
1747 iv = *(unsigned short*)ptr;
1752 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1759 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1763 * pushl <data> 68 <addr32>
1764 * call ffi_callback_call_x86 E8 <disp32>
1772 char *buf = xmalloc(sizeof(char)*16);
1773 *(char*) (buf+0) = 0x54;
1774 *(char*) (buf+1) = 0x68;
1775 *(long*) (buf+2) = (long)data;
1776 *(char*) (buf+6) = 0xE8;
1777 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1778 *(char*) (buf+11) = 0x59;
1779 *(char*) (buf+12) = 0x59;
1780 if (cc_type == FFI_CC_CDECL) {
1781 *(char*) (buf+13) = 0xc3;
1782 *(short*)(buf+14) = 0x9090;
1784 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1788 CHECK_CONS(arg_types);
1790 while (!NILP(arg_types)) {
1791 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1792 byte_size += ((sz+mask)&(~mask));
1793 arg_types = XCDR(arg_types);
1796 *(char*) (buf+13) = 0xc2;
1797 *(short*)(buf+14) = (short)byte_size;
1802 #endif /* __i386__ */
1804 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1805 Create dynamic callback and return pointer to it.
1807 (fun, rtype, argtypes, cctype))
1814 data = list3(fun, rtype, argtypes);
1815 /* Put data as property of the fun, so it(data) wont be GCed */
1816 Fput(fun, Qffi_callback, data);
1817 ptr = Fmake_ffi_object(Qpointer, Qnil);
1819 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1822 error("FFI Callbacks not supported on this configuration");
1824 signal_ferror(Qinternal_error,
1825 "FFI Callbacks not supported on this configuration");
1826 #endif /* SXEMACS */
1827 #endif /* __i386__ */
1834 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1839 DEFSYMBOL(Qc_string);
1844 DEFSYMBOL(Qunsigned_byte);
1845 DEFSYMBOL(Qunsigned_char);
1846 DEFSYMBOL(Qunsigned_int);
1847 DEFSYMBOL(Qunsigned_long);
1848 DEFSYMBOL(Qunsigned_short);
1850 /* ### This is broken, the lrecord needs to be called ffi_object,
1851 and then this would be a DEFSYMBOL_MULTIWORD_PREDICATE(). Not
1852 doing it in this commit, though. */
1853 defsymbol(&Qffiobjectp, "ffi-object-p");
1855 DEFSYMBOL(Qffi_translate_to_foreign);
1856 DEFSYMBOL(Qffi_translate_from_foreign);
1858 DEFSYMBOL(Qffi_callback);
1860 DEFSUBR(Fffi_basic_type_p);
1861 DEFSUBR(Fffi_canonicalise_type);
1862 DEFSUBR(Fffi_size_of_type);
1863 DEFSUBR(Fmake_ffi_object);
1864 DEFSUBR(Fffi_object_p);
1865 DEFSUBR(Fffi_make_pointer);
1866 DEFSUBR(Fffi_object_address);
1867 DEFSUBR(Fffi_object_canonical_type);
1868 DEFSUBR(Fffi_object_type);
1869 DEFSUBR(Fffi_object_size);
1870 DEFSUBR(Fffi_set_storage_size);
1871 DEFSUBR(Fffi_set_object_type);
1872 DEFSUBR(Fffi_fetch);
1874 DEFSUBR(Fffi_store);
1876 DEFSUBR(Fffi_address_of);
1877 DEFSUBR(Fffi_type_alignment);
1878 DEFSUBR(Fffi_slot_offset);
1879 DEFSUBR(Fffi_load_library);
1881 DEFSUBR(Fffi_dlerror);
1882 DEFSUBR(Fffi_defun);
1883 DEFSUBR(Fffi_call_function);
1885 DEFSUBR(Fffi_lisp_object_to_pointer);
1886 DEFSUBR(Fffi_pointer_to_lisp_object);
1887 DEFSUBR(Fffi_plist);
1889 #ifdef EF_USE_ASYNEQ
1890 DEFSUBR(Fffi_call_functionX);
1891 defsymbol(&Qffi_jobp, "ffi-job-p");
1894 DEFSUBR(Fx_device_display);
1896 DEFSUBR(Fffi_make_callback);
1900 reinit_vars_of_ffi(void)
1902 staticpro_nodump(&Vffi_all_objects);
1903 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1909 reinit_vars_of_ffi();
1911 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1912 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1914 Vffi_named_types = Qnil;
1916 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1917 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1919 Vffi_loaded_libraries = Qnil;
1921 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1922 Function to call when the validity of an FFI type shall be checked.
1924 Vffi_type_checker = intern("ffi-type-p");