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)
103 /* Foreign types, not defined as symbols elsewhere. */
104 Lisp_Object Qarray, Qbyte, Qc_data, Qc_string, Qdouble, Qlong, Qstruct;
105 Lisp_Object Qunion, Qunsigned_byte, Qunsigned_char, Qunsigned_int;
106 Lisp_Object Qunsigned_long, Qunsigned_short;
108 #define FFI_POINTERP(type) (EQ(type, Qpointer) \
109 || (CONSP(type) && EQ(XCAR(type), Qpointer)))
111 #define FFI_TPTR(type) (EQ(type, Qc_string) \
112 || EQ(type, Qc_data) \
113 || FFI_POINTERP(type) \
114 || (CONSP(type) && ((EQ(XCAR(type), Qc_data)) \
115 || EQ(XCAR(type), Qarray))))
116 Lisp_Object Qffiobjectp;
117 Lisp_Object Qffi_translate_to_foreign;
118 Lisp_Object Qffi_translate_from_foreign;
120 /* Alist with elements in form (NAME . TYPE) */
121 Lisp_Object Vffi_loaded_libraries;
122 Lisp_Object Vffi_named_types;
124 Lisp_Object Vffi_type_checker;
126 static Lisp_Object Vffi_all_objects;
128 Lisp_Object Qffi_callback;
131 mark_ffiobject(Lisp_Object obj)
133 Lisp_EffiObject *ffio = XEFFIO(obj);
134 mark_object(ffio->type);
135 mark_object(ffio->size);
136 mark_object(ffio->plist);
137 return (ffio->plist);
141 print_ffiobject(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
143 /* This function can GC */
144 Lisp_EffiObject *ffio = XEFFIO(obj);
145 escapeflag = escapeflag; /* shutup compiler */
146 if (print_readably) {
148 error("printing unreadable object #<ffiobject 0x%x>",
151 signal_ferror(Qinternal_error,
152 "printing unreadable object #<ffiobject 0x%x>",
156 WRITE_C_STRING("#<ffiobject ", printcharfun);
157 /* Print FFIO type */
158 if (!NILP(ffio->type)) {
159 WRITE_C_STRING("type=", printcharfun);
160 print_internal(ffio->type, printcharfun, 1);
161 WRITE_C_STRING(" ", printcharfun);
163 WRITE_FMT_STRING(printcharfun,"size=%ld fotype=%d foptr=%p>",
164 (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
167 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
168 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
169 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
170 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
171 {XD_INT, offsetof(Lisp_EffiObject, fotype)},
172 {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
174 {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
176 {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
182 ffi_getprop(Lisp_Object fo, Lisp_Object property)
184 return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
188 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
190 external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
195 ffi_remprop(Lisp_Object fo, Lisp_Object property)
197 return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
202 sizeof_ffiobject(const void *header)
204 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
205 return (sizeof(Lisp_EffiObject) + effio->storage_size);
209 sizeof_ffiobject(const void *header)
211 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
212 return (sizeof(Lisp_EffiObject) + effio->storage_size);
216 /* Define ffiobject implementation */
217 const struct lrecord_implementation lrecord_ffiobject = {
219 .marker = mark_ffiobject,
220 .printer = print_ffiobject,
224 .description = ffiobject_description,
225 .getprop = ffi_getprop,
226 .putprop = ffi_putprop,
227 .remprop = ffi_remprop,
230 .size_in_bytes_method = sizeof_ffiobject,
231 .lrecord_type_index = lrecord_type_ffiobject,
236 /** alignment in union and structures **/
240 * - An entire structure or union is aligned on the same boundary as
241 * its most strictly aligned member.
243 * - Each member is assigned to the lowest available offset with the
244 * appropriate alignment. This may require /internal padding/,
245 * depending on the previous member.
247 * - A structure's size is increased, if necessary, to make it a
248 * multiple of the alignment. This may require /tail padding/,
249 * depending on the last member.
254 * char c; .-------2+---1+---0.
255 * short s; | s |pad | c |
256 * } `--------+----+----'
258 * Internal and Tail padding:
260 * struct { .------------1+---0.
261 * char c; | pad | c |
262 * double d; |-------------+---4|
264 * } |-----------------8|
266 * |------14+-------12|
268 * `--------+---------'
272 * union { .------------1+---0.
273 * char c; | pad | c |
274 * short s; |-------2+----+---0|
276 * } |--------+--------0|
278 * `------------------'
281 ffi_check_type(Lisp_Object type)
283 return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
286 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
287 Return non-nil if TYPE is a basic FFI type.
289 A type is said to be basic, if it is neither a pointer nor a
290 function, and there is a corresponding built-in type in C.
294 if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte) || EQ(type, Qchar)
295 || EQ(type, Qunsigned_char) || EQ(type, Qshort)
296 || EQ(type, Qunsigned_short) || EQ(type, Qint)
297 || EQ(type, Qunsigned_int) || EQ(type, Qlong)
298 || EQ(type, Qunsigned_long) || EQ(type, Qfloat)
299 || EQ(type, Qdouble) || EQ(type, Qvoid)
300 || EQ(type, Qc_string) || EQ(type, Qc_data)
301 || (CONSP(type) && EQ(XCAR(type), Qc_data)))
309 ffi_canonicalise_type(Lisp_Object type)
311 /* this function canNOT GC */
313 while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
314 if EQ(type, Qpointer)
316 type = Fcdr(Fassq(type, Vffi_named_types));
322 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
323 Return FFI type TYPE in a canonical form.
327 Lisp_Object canon_type = ffi_canonicalise_type(type);
328 if (NILP(canon_type)) {
330 signal_simple_error("No such FFI type", type);
332 signal_error(Qinternal_error, "No such FFI type", type);
338 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0, /*
339 Return the size of the foreign type TYPE.
341 Valid foreign types are: `byte', `unsigned-byte', `char',
342 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
343 `long', `unsigned-long', `pointer', `float', `double',
344 `object', and `c-string'.
350 type = ffi_canonicalise_type(type);
353 else if (EQ(type, Qbyte))
354 tsize = sizeof(int8_t);
355 else if (EQ(type, Qunsigned_byte))
356 tsize = sizeof(uint8_t);
357 else if (EQ(type, Qchar))
358 tsize = sizeof(char);
359 else if (EQ(type, Qunsigned_char))
360 tsize = sizeof(unsigned char);
361 else if (EQ(type, Qshort))
362 tsize = sizeof(short);
363 else if (EQ(type, Qunsigned_short))
364 tsize = sizeof(unsigned short);
365 else if (EQ(type, Qint))
367 else if (EQ(type, Qunsigned_int))
368 tsize = sizeof(unsigned int);
369 else if (EQ(type, Qlong))
370 tsize = sizeof(long);
371 else if (EQ(type, Qunsigned_long))
372 tsize = sizeof(unsigned long);
373 else if (EQ(type, Qfloat))
374 tsize = sizeof(float);
375 else if (EQ(type, Qdouble))
376 tsize = sizeof(double);
377 else if (EQ(type, Qc_string))
378 tsize = sizeof(char *);
379 else if (FFI_POINTERP(type))
380 tsize = sizeof(void *);
381 else if (EQ(type, Qc_data))
382 tsize = sizeof(void *);
383 else if (CONSP(type) && EQ(XCAR(type), Qc_data)) {
384 Lisp_Object cdsize = XCDR(type);
386 tsize = XINT(cdsize);
387 } else if (CONSP(type) && EQ(XCAR(type), Qfunction))
388 tsize = sizeof(void(*));
389 else if (CONSP(type) && EQ(XCAR(type), Qarray)) {
390 Lisp_Object atype = Fcar(XCDR(type));
391 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
394 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
395 } else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
396 return Fffi_slot_offset(type, Qnil);
397 } else if (CONSP(type) && EQ(XCAR(type), Qunion)) {
398 Lisp_Object slots = Fcdr(XCDR(type));
403 while (!NILP(slots)) {
404 Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
405 int slot_size = XINT(Fffi_size_of_type(slot_type));
406 if (slot_size > tsize)
412 signal_simple_error("Unrecognized foreign type", type);
414 signal_error(Qinternal_error, "Unrecognized foreign type", type);
418 return make_int(tsize);
421 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
422 Create a new FFI object of type TYPE.
423 If optional argument SIZE is non-nil it should be an
424 integer, in this case additional storage size to hold data
425 of at least length SIZE is allocated.
431 Lisp_Object result = Qnil;
432 Lisp_EffiObject *ffio;
437 /* NOTE: ffi_check_type returns canonical type */
438 ctype = ffi_check_type(type);
440 size = Fffi_size_of_type(type);
443 if (CONSP(ctype) && EQ(XCAR(ctype), Qc_data) && INTP(XCDR(ctype)))
446 cs_or_cd = EQ(ctype, Qc_string) || (EQ(ctype, Qc_data));
447 if ((cs_or_cd && (XINT(size) < 1))
448 || (!(cs_or_cd || FFI_POINTERP(ctype))
449 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
451 signal_simple_error("storage size too small to store type",
454 ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
456 XSETEFFIO(result, ffio);
458 signal_error(Qinternal_error,
459 "storage size too small to store type",
462 ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
464 result = wrap_effio(ffio);
467 ffio->size = Fffi_size_of_type(type);
471 /* Initialize foreign pointer */
472 ffio->fotype = EFFI_FOT_NONE;
473 ffio->storage_size = XINT(size);
474 ffio->fop.ptr = ffio->fostorage;
476 if (!NILP(Vffi_all_objects))
477 XWEAK_LIST_LIST(Vffi_all_objects) =
478 Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
480 RETURN_UNGCPRO(result);
483 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
484 Return non-nil if FO is an FFI object, nil otherwise.
488 return (EFFIOP(fo) ? Qt : Qnil);
491 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
492 Return the address FO points to.
497 return make_float((long)XEFFIO(fo)->fop.ptr);
500 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
501 "Return a pointer pointing to ADDRESS."
509 addr = XINT(address);
510 else if (FLOATP(address))
511 addr = XFLOATINT(address);
514 signal_simple_error("FFI: invalid address type", address);
516 signal_error(Qinternal_error, "FFI: invalid address type",
521 ptr = Fmake_ffi_object(Qpointer, Qnil);
522 XEFFIO(ptr)->fop.ptr = (void*)addr;
526 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
527 Return FO's real type, that is after resolving user defined types.
532 return ffi_canonicalise_type(XEFFIO(fo)->type);
535 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
541 return (XEFFIO(fo)->type);
544 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
545 Cast FO to type TYPE and reassign the cast value.
551 ffi_check_type(type);
552 XEFFIO(fo)->type = type;
557 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
558 Return the size of the allocated space of FO.
563 return (XEFFIO(fo)->size);
566 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
567 Set the size of the allocated space of FO.
573 XEFFIO(fo)->storage_size = XUINT(size);
577 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
578 Load library LIBNAME and return a foreign object handle if successful,
579 or `nil' if the library cannot be loaded.
581 The argument LIBNAME should be the file-name string of a shared object
582 library. Normally you should omit the file extension, as this
583 function will add the appripriate extension for the current platform
586 The library should reside in one of the directories specified by the
587 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
592 #ifdef LTDL_SHLIB_EXT
593 # define EXT LTDL_SHLIB_EXT
594 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
595 # define EXT ".dylib"
598 #endif /* LTDL_SHLIB_EXT */
600 void *handler, *dotpos;
601 Lisp_Object fo = Qnil;
602 Lisp_EffiObject *ffio;
606 CHECK_STRING(libname);
608 /* Add an extension if we need to */
609 dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
610 if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
611 ssize_t liblen = XSTRING_LENGTH(libname);
612 ssize_t soname_len = liblen + sizeof(EXT);
613 soname = xmalloc( soname_len + 1);
614 strncpy(soname, (char *)XSTRING_DATA(libname), liblen+1);
615 strncat(soname, EXT, sizeof(EXT)+1);
618 if ( soname == NULL ) {
619 handler = dlopen((const char *)XSTRING_DATA(libname),
620 RTLD_GLOBAL|RTLD_NOW);
622 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
630 fo = Fmake_ffi_object(Qpointer, Qnil);
633 ffio->fotype = EFFI_FOT_BIND;
634 ffio->fop.ptr = handler;
639 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
640 Make and return a foreign object of type TYPE and bind it to the
643 The argument TYPE can be any type-cell.
644 The argument SYM should be a string naming an arbitrary symbol
645 in one of the loaded libraries.
647 If SYM does not exist in any of the loaded libraries, `nil' is
652 Lisp_Object fo = Qnil;
653 Lisp_EffiObject *ffio;
656 ffi_check_type(type);
660 fo = Fmake_ffi_object(type, Qnil);
662 ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
663 if (ffio->fop.ptr == NULL) {
668 ffio->fotype = EFFI_FOT_BIND;
673 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
674 Return dl error string.
678 const char *dles = dlerror();
680 if (LIKELY(dles != NULL)) {
681 size_t sz = strlen(dles);
682 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
688 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
689 Make and return a foreign object of type TYPE and bind it to the
692 The argument TYPE should be a function type-cell.
693 The argument SYM should be a string naming a function in one of
694 the loaded libraries.
696 If SYM does not exist in any of the loaded libraries, an error
699 This is like `ffi-bind' but for function objects.
703 Lisp_Object fo = Qnil;
704 Lisp_EffiObject *ffio;
707 ffi_check_type(type);
712 fo = Fmake_ffi_object(type, Qnil);
714 ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
715 if (ffio->fop.fun == NULL) {
717 signal_simple_error("Can't define function", sym);
719 signal_error(Qinternal_error, "Can't define function", sym);
723 ffio->fotype = EFFI_FOT_FUNC;
729 * Return alignment policy for struct or union FFI_SU.
730 * x86: Return 1, 2 or 4.
731 * mips: Return 1, 2, 4 or 8.
734 ffi_type_align(Lisp_Object type)
736 type = ffi_canonicalise_type(type);
738 if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte)
739 || EQ(type, Qchar) || EQ(type, Qunsigned_char))
741 if (EQ(type, Qshort) || EQ(type, Qunsigned_short))
744 if (EQ(type, Qdouble))
746 #endif /* FFI_MIPS */
749 } else if (CONSP(type)
750 && (EQ(XCAR(type), Qstruct) || EQ(XCAR(type), Qunion))) {
753 for (al = 0, type = Fcdr(Fcdr(type));
757 Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
758 int tmp_al = ffi_type_align(stype);
770 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
771 Return TYPE alignment.
775 return make_int(ffi_type_align(type));
778 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
779 Return the offset of SLOT in TYPE.
780 SLOT can be either a valid (named) slot in TYPE or `nil'.
781 If SLOT is `nil' return the size of the struct.
786 int lpad, align, retoff;
788 type = ffi_canonicalise_type(type);
791 error("Not struct or union");
793 Fsignal(Qwrong_type_argument,
794 list2(Qstringp, build_string("Not struct or union")));
799 lpad = align = ffi_type_align(type);
800 slots = Fcdr(XCDR(type));
802 while (!NILP(slots)) {
803 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
809 * - for basic types TMP_ALIGN and TMP_SIZE are equal
811 tmp_align = ffi_type_align(tmp_slot);
813 if (EQ(XCAR(XCAR(slots)), slot)) {
815 /* TODO: add support for :offset keyword in SLOT */
816 if (lpad < tmp_align) {
824 tmp_size = XINT(Fffi_size_of_type(tmp_slot));
825 while (tmp_size > 0) {
826 if (lpad < tmp_align) {
830 tmp_size -= tmp_align;
837 if (NILP(slots) && !NILP(slot)) {
839 signal_simple_error("FFI: Slot not found", slot);
841 signal_error(Qinternal_error, "FFI: Slot not found", slot);
844 return make_int(retoff + lpad);
848 * TYPE must be already canonicalised
851 ffi_fetch_foreign(void *ptr, Lisp_Object type)
853 /* this function canNOT GC */
854 Lisp_Object retval = Qnone;
857 retval = make_char(*(char*)ptr);
858 else if (EQ(type, Qunsigned_char))
859 retval = make_char(*(char unsigned*)ptr);
860 else if (EQ(type, Qbyte))
861 retval = make_int(*(char*)ptr);
862 else if (EQ(type, Qunsigned_byte))
863 retval = make_int(*(unsigned char*)ptr);
864 else if (EQ(type, Qshort))
865 retval = make_int(*(short*)ptr);
866 else if (EQ(type, Qunsigned_short))
867 retval = make_int(*(unsigned short*)ptr);
868 else if (EQ(type, Qint))
869 retval = make_int(*(int*)ptr);
870 else if (EQ(type, Qunsigned_int))
871 retval = make_int(*(unsigned int*)ptr);
872 else if (EQ(type, Qlong))
873 retval = make_int(*(long*)ptr);
874 else if (EQ(type, Qunsigned_long))
875 retval = make_int(*(unsigned long*)ptr);
876 else if (EQ(type, Qfloat))
877 retval = make_float(*(float*)ptr);
878 else if (EQ(type, Qdouble))
879 retval = make_float(*(double*)ptr);
880 else if (EQ(type, Qc_string)) {
881 retval = build_ext_string((char*)ptr, Qbinary);
882 } else if (EQ(type, Qvoid)) {
884 } else if (FFI_POINTERP(type)) {
885 retval = Fmake_ffi_object(type, Qnil);
886 XEFFIO(retval)->fop.ptr = *(void**)ptr;
887 } else if (CONSP(type) && EQ(XCAR(type), Qfunction)) {
888 retval = Fmake_ffi_object(type, Qnil);
889 XEFFIO(retval)->fop.fun = (void*)ptr;
890 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
896 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
897 Fetch value from the foreign object FO from OFFSET position.
898 TYPE specifies value for data to be fetched.
902 Lisp_Object origtype = type;
903 Lisp_Object retval = Qnil;
904 Lisp_EffiObject *ffio;
912 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
914 type = ffi_canonicalise_type(type);
917 /* Fetch value and translate it according to translators */
918 retval = ffi_fetch_foreign(ptr, type);
919 if (EQ(retval, Qnone)) {
920 /* Special case for c-data */
921 if (EQ(type, Qc_data) ||
922 (CONSP(type) && EQ(XCAR(type), Qc_data)))
925 if (EQ(type, Qc_data)) {
926 tlen = ffio->storage_size - XINT(offset);
928 CHECK_INT(XCDR(type));
929 tlen = XUINT(XCDR(type));
932 retval = make_ext_string(ptr, tlen, Qbinary);
935 signal_simple_error("Can't fetch for this type", origtype);
937 signal_error(Qinternal_error, "Can't fetch for this type",
942 retval = apply1(Findirect_function(Qffi_translate_from_foreign),
943 list2(retval, origtype));
945 RETURN_UNGCPRO(retval);
948 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
949 Return the element of FARRAY at index IDX (starting with 0).
958 type = ffi_canonicalise_type(XEFFIO(farray)->type);
959 if (!FFI_TPTR(type)) {
961 signal_simple_error("Not an array type", type);
963 signal_error(Qinternal_error, "Not an array type", type);
966 if (EQ(type, Qc_string))
969 type = Fcar(XCDR(type));
971 return Fffi_fetch(farray,
972 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
976 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
977 For foreign object FO at specified OFFSET store data.
978 Type of data is specified by VAL-TYPE and data itself specified in VAL.
980 VAL-TYPE can be either a basic FFI type or an FFI pointer.
981 If VAL-TYPE is a basic FFI type, then VAL can be an
982 ordinary, but suitable Emacs lisp object.
983 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
984 object of the underlying type pointed to.
986 (fo, offset, val_type, val))
988 Lisp_Object origtype = val_type;
989 Lisp_EffiObject *ffio;
996 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
998 val_type = ffi_canonicalise_type(val_type);
1000 /* Translate value */
1001 val = apply1(Findirect_function(Qffi_translate_to_foreign),
1002 list2(val, origtype));
1004 if (EQ(val_type, Qchar) || EQ(val_type, Qunsigned_char)) {
1006 SIGNAL_ERROR(Qwrong_type_argument,
1007 list2(Qcharacterp, val));
1009 *(char*)ptr = XCHAR(val);
1010 } else if (EQ(val_type, Qbyte) || EQ(val_type, Qunsigned_byte)) {
1012 SIGNAL_ERROR(Qwrong_type_argument,
1013 list2(Qintegerp, val));
1015 *(char*)ptr = XINT(val);
1016 } else if (EQ(val_type, Qshort) || EQ(val_type, Qunsigned_short)) {
1018 SIGNAL_ERROR(Qwrong_type_argument,
1019 list2(Qintegerp, val));
1021 *(short*)ptr = (short)XINT(val);
1022 } else if (EQ(val_type, Qint) || EQ(val_type, Qunsigned_int)) {
1024 *(int*)ptr = XINT(val);
1025 } else if (FLOATP(val)) {
1026 fpfloat tmp = XFLOATINT(val);
1027 *(int*)ptr = (int)tmp;
1029 SIGNAL_ERROR(Qwrong_type_argument,
1030 list2(Qfloatp, val));
1032 } else if (EQ(val_type, Qlong) || EQ(val_type, Qunsigned_long)) {
1034 *(long*)ptr = (long)XINT(val);
1035 } else if (FLOATP(val)) {
1036 fpfloat tmp = XFLOATINT(val);
1037 *(long*)ptr = (long int)tmp;
1039 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1041 } else if (EQ(val_type, Qfloat)) {
1043 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1044 *(float*)ptr = XFLOATINT(val);
1045 } else if (EQ(val_type, Qdouble)) {
1047 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1048 *(double*)ptr = XFLOAT_DATA(val);
1049 } else if (EQ(val_type, Qc_string)) {
1053 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1055 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1056 ALLOCA, (tmp, tmplen), Qnil);
1057 if ( tmp != NULL ) {
1058 memcpy((char*)ptr, tmp, tmplen + 1);
1062 (const char *)XSTRING_DATA(val),
1063 XSTRING_LENGTH(val) + 1);
1065 } else if (EQ(val_type, Qc_data) ||
1067 EQ(XCAR(val_type), Qc_data) && INTP(XCDR(val_type)))) {
1068 char *val_ext = NULL;
1069 unsigned int val_ext_len;
1071 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1073 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1074 (val_ext, val_ext_len), Qbinary);
1075 if (val_ext == NULL ||
1076 (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type))))) {
1078 error("storage size too small");
1080 Fsignal(Qrange_error,
1082 build_string("storage size too small")));
1083 #endif /* SXEMACS */
1085 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), Qstruct)) {
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, Qc_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(Qpointer, 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(Qpointer, 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, Qchar) || EQ(type, Qbyte))
1247 *ft = &ffi_type_schar;
1248 else if (EQ(type, Qunsigned_char) || EQ(type, Qunsigned_byte))
1249 *ft = &ffi_type_uchar;
1250 else if (EQ(type, Qshort))
1251 *ft = &ffi_type_sshort;
1252 else if (EQ(type, Qunsigned_short))
1253 *ft = &ffi_type_ushort;
1254 else if (EQ(type, Qint))
1255 *ft = &ffi_type_sint;
1256 else if (EQ(type, Qunsigned_int))
1257 *ft = &ffi_type_uint;
1258 else if (EQ(type, Qunsigned_long))
1259 *ft = &effi_type_ulong;
1260 else if (EQ(type, Qlong))
1261 *ft = &effi_type_slong;
1262 else if (EQ(type, Qfloat))
1263 *ft = &ffi_type_float;
1264 else if (EQ(type, Qdouble))
1265 *ft = &ffi_type_double;
1266 else if (EQ(type, Qvoid))
1267 *ft = &ffi_type_void;
1268 else if (FFI_TPTR(type))
1269 *ft = &ffi_type_pointer;
1270 else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
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 SXE_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);
1501 SXE_MUTEX_LOCK(&ffij->mtx);
1502 WRITE_FMT_STRING(pcf, " carrying #<ffi-job 0x%lx>",
1503 (long unsigned int)ffij);
1504 SXE_MUTEX_UNLOCK(&ffij->mtx);
1509 finish_ffi_job_data(ffi_job_t ffij)
1511 SXE_MUTEX_LOCK(&ffij->mtx);
1512 xfree(ffij->fof_args);
1513 xfree(ffij->sntnl_args);
1514 SXE_MUTEX_UNLOCK(&ffij->mtx);
1515 SXE_MUTEX_FINI(&ffij->mtx);
1517 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1522 finish_ffi_job(worker_job_t job)
1526 lock_worker_job(job);
1527 ffij = ffi_job(job);
1530 finish_ffi_job_data(ffij);
1532 worker_job_data(job) = NULL;
1533 unlock_worker_job(job);
1538 ffi_job_handle(worker_job_t job)
1541 /* usually called from aux threads */
1543 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1544 int nargs, ret = -1;
1546 lock_worker_job(job);
1547 ffij = ffi_job(job);
1548 unlock_worker_job(job);
1549 SXE_MUTEX_LOCK(&ffij->mtx);
1551 nargs = ffij->fof_nargs;
1552 args = ffij->fof_args;
1553 SXE_MUTEX_UNLOCK(&ffij->mtx);
1555 /* can't ... Fmake_ffi_object is not mt-safe */
1556 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1557 retfo = ffij->retfo;
1560 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1561 #endif /* HAVE_LIBFFI */
1563 SXE_MUTEX_LOCK(&ffij->mtx);
1564 ffij->result = retfo;
1565 SXE_MUTEX_UNLOCK(&ffij->mtx);
1568 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1573 ffi_job_finished(worker_job_t job)
1575 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1578 /* called from main thread */
1579 exec_sentinel(job, ffi_job(job));
1583 static struct work_handler_s ffi_job_handler = {
1584 mark_ffi_job, print_ffi_job, finish_ffi_job,
1585 ffi_job_handle, NULL, ffi_job_finished
1589 make_ffi_asyneq_job(ffi_job_t ffij)
1591 /* create a job digestible by the asyneq */
1592 Lisp_Object job = Qnil;
1593 struct gcpro gcpro1;
1596 job = wrap_object(make_worker_job(&ffi_job_handler));
1597 XWORKER_JOB_DATA(job) = ffij;
1598 /* the scratch buffer thingie */
1603 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1604 Call a function referred to by FO with arguments ARGS asynchronously,
1605 return a job object.
1607 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1609 FO should be a foreign binding initiated by `ffi-defun'.
1610 FO-ARGS should be exactly as many foreign data objects as FO needs.
1611 SENTINEL is a lisp sentinel function called when the job finished,
1612 the function should take at least one argument JOB, further arguments
1613 may be specified by passing further SENTINEL-ARGS.
1615 (int nargs, Lisp_Object *args))
1617 Lisp_Object job = Qnil;
1618 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1619 int sntnl_nargs, fof_nargs;
1621 struct gcpro gcpro1, gcpro2;
1623 CHECK_EFFIO(args[0]);
1624 GCPRO1n(job, args, nargs);
1627 /* determine how many args belong to the fof */
1628 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1629 fof_args = &args[1];
1631 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1632 sntnl = args[fof_nargs+1];
1633 sntnl_args = &args[fof_nargs+2];
1639 /* create the job data object */
1640 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1641 sntnl, sntnl_nargs, sntnl_args);
1642 /* now prepare the job to dispatch */
1643 job = make_ffi_asyneq_job(ffij);
1644 /* ... and dispatch it, change its state to queued */
1645 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1646 eq_enqueue(delegate_eq, job);
1647 /* brag about new jobs in the queue */
1648 eq_queue_trigger_all(delegate_eq);
1653 #endif /* EF_USE_ASYNEQ */
1655 extern struct device *decode_x_device(Lisp_Object device);
1657 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1658 Return DEVICE display as FFI object.
1665 fo = Fmake_ffi_object(Qpointer, Qnil);
1666 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1667 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1675 #define FFI_CC_CDECL 0
1677 #if defined __i386__
1679 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1681 Lisp_Object fun, alist = Qnil, retlo, foret;
1682 Lisp_Object rtype, argtypes;
1683 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1686 fun = Fcar(cbk_info);
1687 rtype = Fcar(Fcdr(cbk_info));
1688 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1690 CHECK_LIST(argtypes);
1692 arg_buffer += 4; /* Skip return address */
1693 while (!NILP(argtypes)) {
1694 Lisp_Object result, ctype;
1697 ctype = ffi_canonicalise_type(XCAR(argtypes));
1698 size = XINT(Fffi_size_of_type(ctype));
1699 if (EQ(ctype, Qc_string)) {
1700 char *aptr = *(char**)arg_buffer;
1702 result = ffi_fetch_foreign(aptr, ctype);
1706 result = ffi_fetch_foreign(arg_buffer, ctype);
1707 /* Apply translators and put the result into alist */
1708 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1709 list2(result, XCAR(argtypes)));
1710 alist = Fcons(result, alist);
1713 int sp = (size + mask) & ~mask;
1716 argtypes = XCDR(argtypes);
1718 alist = Fnreverse(alist);
1720 /* Special case, we have no return value */
1721 if (EQ(rtype, Qvoid)) {
1722 GCPRO3(fun, alist, rtype);
1728 GCPRO5(fun, alist, rtype, retlo, foret);
1729 retlo = apply1(fun, alist);
1730 foret = Fmake_ffi_object(rtype, Qnil);
1731 Fffi_store(foret, make_int(0), rtype, retlo);
1732 ptr = (void*)XEFFIO(foret)->fop.ptr;
1733 if (EQ(rtype, Qdouble)) {
1736 asm volatile ("fldl (%0)" :: "a" (ptr));
1739 } else if (EQ(rtype, Qfloat)) {
1742 asm volatile ("flds (%0)" :: "a" (ptr));
1748 if (EQ(rtype, Qbyte) || EQ(rtype, Qchar))
1750 else if (EQ(rtype, Qunsigned_byte) || EQ(rtype, Qunsigned_char))
1751 iv = *(char unsigned*)ptr;
1752 else if (EQ(rtype, Qshort))
1754 else if (EQ(rtype, Qunsigned_short))
1755 iv = *(unsigned short*)ptr;
1760 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1767 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1771 * pushl <data> 68 <addr32>
1772 * call ffi_callback_call_x86 E8 <disp32>
1780 char *buf = xmalloc(sizeof(char)*16);
1781 *(char*) (buf+0) = 0x54;
1782 *(char*) (buf+1) = 0x68;
1783 *(long*) (buf+2) = (long)data;
1784 *(char*) (buf+6) = 0xE8;
1785 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1786 *(char*) (buf+11) = 0x59;
1787 *(char*) (buf+12) = 0x59;
1788 if (cc_type == FFI_CC_CDECL) {
1789 *(char*) (buf+13) = 0xc3;
1790 *(short*)(buf+14) = 0x9090;
1792 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1796 CHECK_CONS(arg_types);
1798 while (!NILP(arg_types)) {
1799 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1800 byte_size += ((sz+mask)&(~mask));
1801 arg_types = XCDR(arg_types);
1804 *(char*) (buf+13) = 0xc2;
1805 *(short*)(buf+14) = (short)byte_size;
1810 #endif /* __i386__ */
1812 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1813 Create dynamic callback and return pointer to it.
1815 (fun, rtype, argtypes, cctype))
1822 data = list3(fun, rtype, argtypes);
1823 /* Put data as property of the fun, so it(data) wont be GCed */
1824 Fput(fun, Qffi_callback, data);
1825 ptr = Fmake_ffi_object(Qpointer, Qnil);
1827 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1828 #endif /* __i386__ */
1835 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1840 DEFSYMBOL(Qc_string);
1845 DEFSYMBOL(Qunsigned_byte);
1846 DEFSYMBOL(Qunsigned_char);
1847 DEFSYMBOL(Qunsigned_int);
1848 DEFSYMBOL(Qunsigned_long);
1849 DEFSYMBOL(Qunsigned_short);
1851 /* ### This is broken, the lrecord needs to be called ffi_object,
1852 and then this would be a DEFSYMBOL_MULTIWORD_PREDICATE(). Not
1853 doing it in this commit, though. */
1854 defsymbol(&Qffiobjectp, "ffi-object-p");
1856 DEFSYMBOL(Qffi_translate_to_foreign);
1857 DEFSYMBOL(Qffi_translate_from_foreign);
1859 DEFSYMBOL(Qffi_callback);
1861 DEFSUBR(Fffi_basic_type_p);
1862 DEFSUBR(Fffi_canonicalise_type);
1863 DEFSUBR(Fffi_size_of_type);
1864 DEFSUBR(Fmake_ffi_object);
1865 DEFSUBR(Fffi_object_p);
1866 DEFSUBR(Fffi_make_pointer);
1867 DEFSUBR(Fffi_object_address);
1868 DEFSUBR(Fffi_object_canonical_type);
1869 DEFSUBR(Fffi_object_type);
1870 DEFSUBR(Fffi_object_size);
1871 DEFSUBR(Fffi_set_storage_size);
1872 DEFSUBR(Fffi_set_object_type);
1873 DEFSUBR(Fffi_fetch);
1875 DEFSUBR(Fffi_store);
1877 DEFSUBR(Fffi_address_of);
1878 DEFSUBR(Fffi_type_alignment);
1879 DEFSUBR(Fffi_slot_offset);
1880 DEFSUBR(Fffi_load_library);
1882 DEFSUBR(Fffi_dlerror);
1883 DEFSUBR(Fffi_defun);
1884 DEFSUBR(Fffi_call_function);
1886 DEFSUBR(Fffi_lisp_object_to_pointer);
1887 DEFSUBR(Fffi_pointer_to_lisp_object);
1888 DEFSUBR(Fffi_plist);
1890 #ifdef EF_USE_ASYNEQ
1891 DEFSUBR(Fffi_call_functionX);
1892 defsymbol(&Qffi_jobp, "ffi-job-p");
1895 DEFSUBR(Fx_device_display);
1897 DEFSUBR(Fffi_make_callback);
1901 reinit_vars_of_ffi(void)
1903 staticpro_nodump(&Vffi_all_objects);
1904 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1910 reinit_vars_of_ffi();
1912 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1913 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1915 Vffi_named_types = Qnil;
1917 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1918 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1920 Vffi_loaded_libraries = Qnil;
1922 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1923 Function to call when the validity of an FFI type shall be checked.
1925 Vffi_type_checker = intern("ffi-type-p");