From f67be57b3719f4b0ad6cc015e7bd019cae6e302a Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 10 Oct 2005 10:23:42 +0000 Subject: [PATCH] Automatic generation of calls to C functions, plus fixes on the handling of :CSTRING arguments to C-INLINE --- src/CHANGELOG | 9 + src/aclocal.m4 | 22 +++ src/c/Makefile.in | 4 + src/c/ffi.d | 407 ++++++++++++++++++++++++++---------------- src/c/gbc.d | 5 + src/c/load.d | 3 + src/c/main.d | 7 + src/c/symbols_list.h | 2 + src/c/symbols_list2.h | 2 + src/cmp/cmpffi.lsp | 15 +- src/configure | 22 +++ src/configure.in | 1 + src/h/config.h.in | 4 + src/h/external.h | 4 + src/h/internal.h | 60 +++++++ src/lsp/ffi.lsp | 29 ++- 16 files changed, 429 insertions(+), 167 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 55aa402fd..bd209f314 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -51,6 +51,15 @@ ECL 0.9h with a user-defined foreign type that is an alias for a primitive type (M. Goffioul) + - C-INLINE forms which contain :CSTRING as argument are now automatically + rewritten in terms of WITH-CSTRING. This way, the null terminated strings + that are generated at run time will not be garbage collected. + + - There is a primitive implementation of run-time automatic generation of + interfaces to C functions. This allows us to call functions in shared + libraries without need of the compiler. The current implementation only + works on the intel architecture with GCC, but should be easily extended. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/aclocal.m4 b/src/aclocal.m4 index 6c0b8ee8d..17454b70b 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -497,3 +497,25 @@ AC_MSG_RESULT([${CFLAGS}]) AC_MSG_CHECKING([Linker flags]) AC_MSG_RESULT([${LDFLAGS}]) ]) + +dnl +dnl ------------------------------------------------------------ +dnl Do we have a non-portable implementation of calls to foreign +dnl functions? +dnl +AC_DEFUN([ECL_FFI],[ +AC_MSG_CHECKING([whether we can dynamically build calls to C functions]) +case "${host_cpu}" in + i686 |i586 | pentium* | athlon* ) + EXTRA_OBJS="${EXTRA_OBJS} ffi_x86.o" + dynamic_ffi=yes + ;; + *) + dynamic_ffi=no + ;; +esac +AC_MSG_RESULT([${dynamic_ffi}]) +if test "$dynamic_ffi" = "yes" ; then + AC_DEFINE(ECL_DYNAMIC_FFI, 1, [we can build calls to foreign functions]) +fi +]) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 15e1c5d97..4e7d65d60 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -56,6 +56,8 @@ OBJS = main.o symbol.o package.o list.o\ $(CC) $(CFLAGS) -o $@ $< %.c: %.d $(DPP) $(HFILES) if test -f ../CROSS-DPP ; then ../CROSS-DPP $< $@ ; else $(DPP) $< $@ ; fi +%.c: arch/%.d $(DPP) $(HFILES) + if test -f ../CROSS-DPP ; then ../CROSS-DPP $< $@ ; else $(DPP) $< $@ ; fi all: $(DPP) external.h ../libeclmin.a ../cinit.o .PHONY: all @@ -107,6 +109,8 @@ $(srcdir)/symbols_list2.h: $(srcdir)/symbols_list.h Makefile # gbc.o: gbc.c $(HFILES) $(CC) $(CFLAGS) -O0 gbc.c -o $@ +ffi_x86.o: ffi_x86.c $(HFILES) + $(CC) $(CFLAGS) -O0 ffi_x86.c -o $@ # # This reduces the overhead of jumping to other functions # diff --git a/src/c/ffi.d b/src/c/ffi.d index 59f1f95cc..5cf30700e 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -14,6 +14,43 @@ #include #include "ecl.h" +#include "internal.h" + +static const cl_object ecl_foreign_type_table[] = { + @':char', + @':unsigned-char', + @':byte', + @':unsigned-byte', + @':short', + @':unsigned-short', + @':int', + @':unsigned-int', + @':long', + @':unsigned-long', + @':pointer-void', + @':cstring', + @':object', + @':float', + @':double', + @':void'}; + +static unsigned int ecl_foreign_type_size[] = { + sizeof(char), + sizeof(unsigned char), + sizeof(int8_t), + sizeof(uint8_t), + sizeof(short), + sizeof(unsigned short), + sizeof(int), + sizeof(unsigned int), + sizeof(long), + sizeof(unsigned long), + sizeof(void *), + sizeof(char *), + sizeof(cl_object), + sizeof(float), + sizeof(double), + 0}; cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) @@ -170,176 +207,148 @@ si_foreign_data_set(cl_object f, cl_object andx, cl_object value) @(return value) } -cl_object -si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object tag) +enum ecl_ffi_tag +ecl_foreign_type_code(cl_object type) { - cl_object output; - cl_index ndx = fixnnint(andx); - cl_index limit = f->foreign.size; - void *p; - - if (type_of(f) != t_foreign) { - FEwrong_type_argument(@'si::foreign-data', f); + int i; + for (i = 0; i <= ECL_FFI_VOID; i++) { + if (type == ecl_foreign_type_table[i]) + return (enum ecl_ffi_tag)i; } - if (ndx >= limit) { - ERROR: FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - p = (void*)(f->foreign.data + ndx); - if (tag == @':byte') { - if (ndx + sizeof(int8_t) > limit) goto ERROR; - output = MAKE_FIXNUM(*(int8_t *)p); - } else if (tag == @':unsigned-byte') { - if (ndx + sizeof(uint8_t) > limit) goto ERROR; - output = MAKE_FIXNUM(*(uint8_t *)p); - } else if (tag == @':char') { - if (ndx + sizeof(char) > limit) goto ERROR; - output = CODE_CHAR(*(char *)p); - } else if (tag == @':unsigned-char') { - if (ndx + sizeof(unsigned char) > limit) goto ERROR; - output = CODE_CHAR(*(unsigned char *)p); - } else if (tag == @':short') { - if (ndx + sizeof(short) > limit) goto ERROR; - output = MAKE_FIXNUM(*(short *)p); - } else if (tag == @':unsigned-short') { - if (ndx + sizeof(unsigned short) > limit) goto ERROR; - output = MAKE_FIXNUM(*(unsigned short *)p); - } else if (tag == @':int') { - if (ndx + sizeof(int) > limit) goto ERROR; - output = make_integer(*(int *)p); - } else if (tag == @':unsigned-int') { - if (ndx + sizeof(unsigned int) > limit) goto ERROR; - output = make_unsigned_integer(*(unsigned int *)p); - } else if (tag == @':long') { - if (ndx + sizeof(long) > limit) goto ERROR; - output = make_integer(*(long *)p); - } else if (tag == @':unsigned-long') { - if (ndx + sizeof(unsigned long) > limit) goto ERROR; - output = make_unsigned_integer(*(unsigned long *)p); - } else if (tag == @':pointer-void') { - if (ndx + sizeof(void *) > limit) goto ERROR; - output = ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); - } else if (tag == @':cstring') { - if (ndx + sizeof(char *) > limit) goto ERROR; - output = *(char **)p ? make_simple_string(*(char **)p) : Cnil; - } else if (tag == @':object') { - if (ndx + sizeof(cl_object) > limit) goto ERROR; - output = *(cl_object *)p; - } else if (tag == @':float') { - if (ndx + sizeof(float) > limit) goto ERROR; - output = make_shortfloat(*(float *)p); - } else if (tag == @':double') { - if (ndx + sizeof(double) > limit) goto ERROR; - output = make_longfloat(*(double *)p); - } else { - FEerror("~A does not denote a foreign type.", 1, tag); - } - @(return output) + FEerror("~A does not denote an elementary foreign type.", 1, type); + return ECL_FFI_VOID; } cl_object -si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object tag, cl_object value) +ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag) +{ + switch (tag) { + case ECL_FFI_CHAR: + return CODE_CHAR(*(char *)p); + case ECL_FFI_UNSIGNED_CHAR: + return CODE_CHAR(*(unsigned char *)p); + case ECL_FFI_BYTE: + return MAKE_FIXNUM(*(int8_t *)p); + case ECL_FFI_UNSIGNED_BYTE: + return MAKE_FIXNUM(*(uint8_t *)p); + case ECL_FFI_SHORT: + return MAKE_FIXNUM(*(short *)p); + case ECL_FFI_UNSIGNED_SHORT: + return MAKE_FIXNUM(*(unsigned short *)p); + case ECL_FFI_INT: + return make_integer(*(int *)p); + case ECL_FFI_UNSIGNED_INT: + return make_unsigned_integer(*(unsigned int *)p); + case ECL_FFI_LONG: + return make_integer(*(long *)p); + case ECL_FFI_UNSIGNED_LONG: + return make_unsigned_integer(*(unsigned long *)p); + case ECL_FFI_POINTER_VOID: + return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); + case ECL_FFI_CSTRING: + return *(char **)p ? make_simple_string(*(char **)p) : Cnil; + case ECL_FFI_OBJECT: + return *(cl_object *)p; + case ECL_FFI_FLOAT: + return make_shortfloat(*(float *)p); + case ECL_FFI_DOUBLE: + return make_longfloat(*(double *)p); + case ECL_FFI_VOID: + return Cnil; + } +} + +void +ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value) +{ + switch (tag) { + case ECL_FFI_CHAR: + *(char *)p = char_code(value); + break; + case ECL_FFI_UNSIGNED_CHAR: + *(unsigned char*)p = char_code(value); + break; + case ECL_FFI_BYTE: + *(int8_t *)p = fixint(value); + break; + case ECL_FFI_UNSIGNED_BYTE: + *(uint8_t *)p = fixnnint(value); + break; + case ECL_FFI_SHORT: + *(short *)p = fixint(value); + break; + case ECL_FFI_UNSIGNED_SHORT: + *(unsigned short *)p = fixnnint(value); + break; + case ECL_FFI_INT: + *(int *)p = fixint(value); + break; + case ECL_FFI_UNSIGNED_INT: + *(unsigned int *)p = fixnnint(value); + break; + case ECL_FFI_LONG: + *(long *)p = fixint(value); + break; + case ECL_FFI_UNSIGNED_LONG: + *(unsigned long *)p = fixnnint(value); + break; + case ECL_FFI_POINTER_VOID: + *(void **)p = ecl_foreign_data_pointer_safe(value); + break; + case ECL_FFI_CSTRING: + *(char **)p = value == Cnil ? NULL : value->string.self; + break; + case ECL_FFI_OBJECT: + *(cl_object *)p = value; + break; + case ECL_FFI_FLOAT: + *(float *)p = object_to_float(value); + break; + case ECL_FFI_DOUBLE: + *(double *)p = object_to_double(value); + break; + case ECL_FFI_VOID: + break; + } +} + +cl_object +si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object type) +{ + cl_index ndx = fixnnint(andx); + cl_index limit = f->foreign.size; + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ndx >= limit || (ndx + ecl_foreign_type_size[tag] > limit)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + if (type_of(f) != t_foreign) { + FEwrong_type_argument(@'si::foreign-data', f); + } + @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag)) +} + +cl_object +si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value) { cl_index ndx = fixnnint(andx); cl_index limit = f->foreign.size; void *p; - + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ndx >= limit || ndx + ecl_foreign_type_size[tag] > limit) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } if (type_of(f) != t_foreign) { FEwrong_type_argument(@'si::foreign-data', f); } - if (ndx >= limit) { - ERROR: FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - p = (void*)(f->foreign.data + ndx); - if (tag == @':byte') { - if (ndx + sizeof(int8_t) > limit) goto ERROR; - *(int8_t *)p = fixint(value); - } else if (tag == @':unsigned-byte') { - if (ndx + sizeof(uint8_t) > limit) goto ERROR; - *(uint8_t *)p = fixnnint(value); - } else if (tag == @':char') { - if (ndx + sizeof(char) > limit) goto ERROR; - *(char *)p = char_code(value); - } else if (tag == @':unsigned-char') { - if (ndx + sizeof(unsigned char) > limit) goto ERROR; - *(unsigned char*)p = char_code(value); - } else if (tag == @':short') { - if (ndx + sizeof(short) > limit) goto ERROR; - *(short *)p = fixint(value); - } else if (tag == @':unsigned-short') { - if (ndx + sizeof(unsigned short) > limit) goto ERROR; - *(unsigned short *)p = fixnnint(value); - } else if (tag == @':int') { - if (ndx + sizeof(int) > limit) goto ERROR; - *(int *)p = fixint(value); - } else if (tag == @':unsigned-int') { - if (ndx + sizeof(unsigned int) > limit) goto ERROR; - *(unsigned int *)p = fixnnint(value); - } else if (tag == @':long') { - if (ndx + sizeof(long) > limit) goto ERROR; - *(long *)p = fixint(value); - } else if (tag == @':unsigned-long') { - if (ndx + sizeof(unsigned long) > limit) goto ERROR; - *(unsigned long *)p = fixnnint(value); - } else if (tag == @':pointer-void') { - if (ndx + sizeof(void *) > limit) goto ERROR; - *(void **)p = ecl_foreign_data_pointer_safe(value); - } else if (tag == @':cstring') { - if (ndx + sizeof(void *) > limit) goto ERROR; - *(char **)p = value == Cnil ? NULL : value->string.self; - } else if (tag == @':object') { - if (ndx + sizeof(cl_object) > limit) goto ERROR; - *(cl_object *)p = value; - } else if (tag == @':float') { - if (ndx + sizeof(float) > limit) goto ERROR; - *(float *)p = object_to_float(value); - } else if (tag == @':double') { - if (ndx + sizeof(double) > limit) goto ERROR; - *(double *)p = object_to_double(value); - } else { - FEerror("~A does not denote a foreign type.", 1, tag); - } + ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value); @(return value) } cl_object -si_size_of_foreign_elt_type(cl_object tag) +si_size_of_foreign_elt_type(cl_object type) { - cl_fixnum size; - - if (tag == @':byte') { - size = sizeof(int8_t); - } else if (tag == @':unsigned-byte') { - size = sizeof(uint8_t); - } else if (tag == @':char') { - size = sizeof(char); - } else if (tag == @':unsigned-char') { - size = sizeof(unsigned char); - } else if (tag == @':short') { - size = sizeof(short); - } else if (tag == @':unsigned-short') { - size = sizeof(unsigned short); - } else if (tag == @':int') { - size = sizeof(int); - } else if (tag == @':unsigned-int') { - size = sizeof(unsigned int); - } else if (tag == @':long') { - size = sizeof(long); - } else if (tag == @':unsigned-long') { - size = sizeof(unsigned long); - } else if (tag == @':pointer-void') { - size = sizeof(void *); - } else if (tag == @':cstring') { - size = sizeof(char*); - } else if (tag == @':object') { - size = sizeof(cl_object); - } else if (tag == @':float') { - size = sizeof(float); - } else if (tag == @':double') { - size = sizeof(double); - } else { - FEerror("~A does not denote a foreign type.", 1, tag); - } - @(return MAKE_FIXNUM(size)) + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + @(return MAKE_FIXNUM(ecl_foreign_type_size[tag])) } cl_object @@ -419,3 +428,95 @@ OUTPUT: else FEerror("FIND-FOREIGN-SYMBOL: Could not load foreign symbol ~S from module ~S (Error: ~S)", 3, var, module, output); } + +#ifdef ECL_DYNAMIC_FFI + +static void +ecl_fficall_overflow() +{ + FEerror("Stack overflow on SI:CALL-CFUN", 0); +} + +void +ecl_fficall_prepare(cl_object return_type, cl_object arg_type) +{ + struct ecl_fficall *fficall = cl_env.fficall; + fficall->buffer_sp = fficall->buffer; + fficall->buffer_size = 0; + fficall->cstring = Cnil; +} + +void +ecl_fficall_push_bytes(void *data, size_t bytes) +{ + struct ecl_fficall *fficall = cl_env.fficall; + fficall->buffer_size += bytes; + if (fficall->buffer_size >= ECL_FFICALL_LIMIT) + ecl_fficall_overflow(); + memcpy(fficall->buffer_sp, (char*)data, bytes); + fficall->buffer_sp += bytes; +} + +void +ecl_fficall_push_int(int data) +{ + ecl_fficall_push_bytes(&data, sizeof(int)); +} + +void +ecl_fficall_align(int data) +{ + struct ecl_fficall *fficall = cl_env.fficall; + if (data == 1) + return; + else { + size_t sp = fficall->buffer_sp - fficall->buffer; + size_t mask = data - 1; + size_t new_sp = (sp + mask) & ~mask; + if (new_sp >= ECL_FFICALL_LIMIT) + ecl_fficall_overflow(); + fficall->buffer_sp = fficall->buffer + new_sp; + fficall->buffer_size = new_sp; + } +} + +cl_object +si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types, + cl_object args) +{ + struct ecl_fficall *fficall = cl_env.fficall; + void *cfun = ecl_foreign_data_pointer_safe(fun); + cl_object object; + enum ecl_ffi_tag return_type_tag = ecl_foreign_type_code(return_type); + + ecl_fficall_prepare(return_type, arg_types); + while (CONSP(arg_types)) { + enum ecl_ffi_tag type; + if (!CONSP(args)) { + FEerror("In SI:CALL-CFUN, mismatch between argument types and argument list: ~A vs ~A", 0); + } + type = ecl_foreign_type_code(CAR(arg_types)); + if (type == ECL_FFI_CSTRING) { + object = ecl_null_terminated_string(CAR(args)); + if (CAR(args) != object) + fficall->cstring = + CONS(object, fficall->cstring); + } else { + object = CAR(args); + } + ecl_foreign_data_set_elt(&fficall->output, type, object); + ecl_fficall_push_arg(&fficall->output, type); + arg_types = CDR(arg_types); + args = CDR(args); + } + ecl_fficall_execute(cfun, fficall, return_type_tag); + object = ecl_foreign_data_ref_elt(&fficall->output, return_type_tag); + + fficall->buffer_size = 0; + fficall->buffer_sp = fficall->buffer; + fficall->cstring = Cnil; + + @(return object) +} + +#endif /* ECL_DYNAMIC_FFI */ diff --git a/src/c/gbc.d b/src/c/gbc.d index 0b28f3657..ff0e766c5 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -495,6 +495,11 @@ mark_cl_env(struct cl_env_struct *env) mark_stack_conservative((cl_ptr)env->cs_org, (cl_ptr)(&where)); # endif /* DOWN_STACK */ #endif /* THREADS */ + +#ifdef ECL_FFICALL + mark_contblock(env->fficall, sizeof(struct ecl_fficall)); + mark_object(((struct ecl_fficall*)env->fficall)->cstring); +#endif } static void diff --git a/src/c/load.d b/src/c/load.d index b054ecf6b..ca9f77a57 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -97,6 +97,9 @@ ecl_library_symbol(cl_object block, const char *symbol) { CloseHandle(hndSnap); } return hnd; +#endif +#ifdef HAVE_DLFCN_H + return dlsym(0, symbol); #endif } else { #ifdef HAVE_DLFCN_H diff --git a/src/c/main.d b/src/c/main.d index 30d345e29..de6dce76e 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -79,6 +79,10 @@ ecl_init_env(struct cl_env_struct *env) # endif /* THREADS */ #endif /* !GBC_BOEHM */ +#ifdef ECL_DYNAMIC_FFI + env->fficall = malloc(sizeof(struct ecl_fficall)); +#endif + init_stacks(&i); } @@ -433,6 +437,9 @@ cl_boot(int argc, char **argv) #endif #ifdef ECL_CLOS_STREAMS ADD_FEATURE("CLOS-STREAMS"); +#endif +#ifdef ECL_DYNAMIC_FFI + ADD_FEATURE("DFFI"); #endif /* This is assumed in all systems */ ADD_FEATURE("IEEE-FLOATING-POINT"); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index ba22e73a6..7d713307e 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1552,6 +1552,8 @@ cl_symbols[] = { {SYS_ "*CODE-WALKER*", SI_SPECIAL, NULL, -1, OBJNULL}, +{SYS_ "CALL-CFUN", SI_ORDINARY, si_call_cfun, 4, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 73d9bb035..df834b2a3 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1552,6 +1552,8 @@ cl_symbols[] = { {SYS_ "*CODE-WALKER*",NULL}, +{SYS_ "CALL-CFUN","si_call_cfun"}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 680b71656..60192d4b6 100644 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -255,16 +255,17 @@ ;; null-terminated strings, but not all of our lisp strings will ;; be null terminated. In particular, those with a fill pointer ;; will not. - (let ((ndx (position :cstring arguments))) + (let ((ndx (position :cstring arg-types))) (when ndx (let* ((var (gensym)) - (value (elt ndx arguments))) - (setf (elt ndx arguments) var - (elt ndx arg-types) :char*) + (value (elt arguments ndx))) + (setf (elt arguments ndx) var + (elt arg-types ndx) :char*) (return-from c1c-inline - `(with-ctring (,var ,value) - (c1c-inline ,arguments ,arg-types ,output-type ,c-expression - ,@rest)))))) + (c1expr + `(ffi::with-ctring (,var ,value) + (c1c-inline ,arguments ,arg-types ,output-type ,c-expression + ,@rest))))))) ;; Find out the output types of the inline form. The syntax is rather relax ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) (flet ((produce-type-pair (type) diff --git a/src/configure b/src/configure index 35994b482..7d8380569 100755 --- a/src/configure +++ b/src/configure @@ -6795,6 +6795,28 @@ rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi +echo "$as_me:$LINENO: checking whether we can dynamically build calls to C functions" >&5 +echo $ECHO_N "checking whether we can dynamically build calls to C functions... $ECHO_C" >&6 +case "${host_cpu}" in + i686 |i586 | pentium* | athlon* ) + EXTRA_OBJS="${EXTRA_OBJS} ffi_x86.o" + dynamic_ffi=yes + ;; + *) + dynamic_ffi=no + ;; +esac +echo "$as_me:$LINENO: result: ${dynamic_ffi}" >&5 +echo "${ECHO_T}${dynamic_ffi}" >&6 +if test "$dynamic_ffi" = "yes" ; then + +cat >>confdefs.h <<\_ACEOF +#define ECL_DYNAMIC_FFI 1 +_ACEOF + +fi + + echo "$as_me:$LINENO: checking whether stack growns downwards" >&5 echo $ECHO_N "checking whether stack growns downwards... $ECHO_C" >&6 diff --git a/src/configure.in b/src/configure.in index 46acda827..082343768 100644 --- a/src/configure.in +++ b/src/configure.in @@ -330,6 +330,7 @@ fi ECL_LINEFEED_MODE ECL_FIND_SETJMP ECL_FILE_STRUCTURE +ECL_FFI dnl ----------------------------------------------------------------------- dnl Study the call conventions diff --git a/src/h/config.h.in b/src/h/config.h.in index 274558274..34567846e 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -149,6 +149,10 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey; /* Bytecodes and arguments are 8 and 16 bits large, respectively */ #undef ECL_SMALL_BYTECODES +/* We have non-portable implementation of FFI calls */ +#undef ECL_DYNAMIC_FFI + + /* * SYSTEM FEATURES: */ diff --git a/src/h/external.h b/src/h/external.h index 8de946129..e54c43cd1 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -100,6 +100,9 @@ struct cl_env_struct { cl_object own_process; #endif int interrupt_pending; + + /* foreign function interface */ + void *fficall; }; #ifndef __GNUC__ @@ -505,6 +508,7 @@ extern cl_object si_null_pointer_p(cl_object f); extern cl_object si_size_of_foreign_elt_type(cl_object tag); extern cl_object si_load_foreign_module(cl_object module); extern cl_object si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size); +extern cl_object si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types, cl_object args); extern cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data); extern cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size); diff --git a/src/h/internal.h b/src/h/internal.h index 29e49ea42..77818222b 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -68,6 +68,66 @@ struct cl_compiler_env { #define cl_stack_ref(n) cl_env.stack[n] #define cl_stack_index() (cl_env.stack_top-cl_env.stack) +/* ffi.d */ + +#define ECL_FFICALL_LIMIT 256 + +enum ecl_ffi_tag { + ECL_FFI_CHAR = 0, + ECL_FFI_UNSIGNED_CHAR, + ECL_FFI_BYTE, + ECL_FFI_UNSIGNED_BYTE, + ECL_FFI_SHORT, + ECL_FFI_UNSIGNED_SHORT, + ECL_FFI_INT, + ECL_FFI_UNSIGNED_INT, + ECL_FFI_LONG, + ECL_FFI_UNSIGNED_LONG, + ECL_FFI_POINTER_VOID, + ECL_FFI_CSTRING, + ECL_FFI_OBJECT, + ECL_FFI_FLOAT, + ECL_FFI_DOUBLE, + ECL_FFI_VOID +}; + +union ecl_ffi_values { + char c; + unsigned char uc; + int8_t b; + uint8_t ub; + int i; + unsigned int ui; + short s; + unsigned short us; + long l; + unsigned long ul; + void *pv; + char *pc; + cl_object o; + float f; + double d; +}; + +struct ecl_fficall { + char *buffer_sp; + size_t buffer_size; + union ecl_ffi_values output; + char buffer[ECL_FFICALL_LIMIT]; + cl_object cstring; +}; + +enum ecl_ffi_tag ecl_foreign_type_code(cl_object type); +void ecl_fficall_prepare(cl_object return_type, cl_object arg_types); +void ecl_fficall_push_bytes(void *data, size_t bytes); +void ecl_fficall_push_int(int word); +void ecl_fficall_align(int data); +cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag type); +void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag type, cl_object value); + +void ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type); +void ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type); + /* file.d */ /* diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 57474a678..4894271aa 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -508,10 +508,24 @@ (subseq "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z" 0 (max 0 (1- (* nargs 3)))))) +;;; FIXME! We should turn this into a closure generator that produces no code. +#+DFFI +(defmacro def-lib-function (name args &key returning module) + (multiple-value-bind (c-name lisp-name) (if (consp name) + (values-list name) + (values (string name) name)) + (let* ((return-type (ffi::%convert-to-return-type returning)) + (return-required (not (eq return-type :void))) + (argtypes (mapcar #'(lambda (a) (ffi::%convert-to-arg-type (second a))) args))) + `(let ((c-fun (find-foreign-symbol ,c-name ,module :pointer-void 0))) + (defun ,lisp-name ,(mapcar #'first args) + (call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args)))))))) + (defmacro def-function (name args &key module (returning :void)) - (cond ((and module (macro-function (find-symbol "DEF-LIB-FUNCTION" "FFI"))) - `(def-lib-function ,name ,args :returning ,returning :module ,module)) - (t + #+DFFI + (when module + (return-from def-function + `(def-lib-function ,name ,args :returning ,returning :module ,module))) (multiple-value-bind (c-name lisp-name) (lisp-to-c-name name) (let* ((arguments (mapcar #'first args)) @@ -535,7 +549,7 @@ (error "FFI can only handle C functions with up to 36 arguments")) `(defun ,lisp-name (,@arguments) ,inline-form) - ))))) + ))) (defmacro def-foreign-var (name type module) ;(declare (ignore module)) @@ -628,9 +642,10 @@ `(eval-when (:compile-toplevel) (setf ,csl (nconc ,csl (copy-list ',args))))))) -(eval-when (:load-toplevel) - (defmacro c-inline (&rest args) - '(error "The special form c-inline cannot be used in the interpreter."))) +(eval-when (:load-toplevel :execute) + (defmacro c-inline (args arg-types ret-type &rest others) + `(error "The special form c-inline cannot be used in the interpreter: ~A" + (list (list ,@args) ',arg-types ',ret-type ,@others)))) (defmacro definline (fun arg-types type code) `(eval-when (:compile-toplevel :load-toplevel :execute)