diff --git a/msvc/ecl/config.h.msvc6 b/msvc/ecl/config.h.msvc6 index e944b8290..0c4d9e6c4 100644 --- a/msvc/ecl/config.h.msvc6 +++ b/msvc/ecl/config.h.msvc6 @@ -84,6 +84,15 @@ /* Stack grows downwards */ #define ECL_DOWN_STACK 1 +/* We have libffi and can use it */ +/*#undef HAVE_LIBFFI*/ + +/* We have non-portable implementation of FFI calls */ +/* Only used as a last resort, when libffi is missin */ +#ifndef HAVE_LIBFFI +#define ECL_DYNAMIC_FFI 1 +#endif + /* We have non-portable implementation of FFI calls */ #define ECL_DYNAMIC_FFI 1 diff --git a/src/CHANGELOG b/src/CHANGELOG index b51624f5d..102a80a60 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -37,6 +37,9 @@ ECL 9.7.2: - For places defined with the simple form of DEFSETF, SETF now produces a simpler expansion, without a surrounding LET* form. + - The dynamic FFI is now implemented using libffi. This extends the portability + and removes the previous, error prone implementation. + * Bugs fixed: - SI:GET-LIBRARY-PATHNAME did not work properly in Windows. diff --git a/src/c/arch/ffi_x86.d b/src/c/arch/ffi_x86.d index f43b88ec8..db8b756aa 100644 --- a/src/c/arch/ffi_x86.d +++ b/src/c/arch/ffi_x86.d @@ -17,6 +17,8 @@ #include #include +#if !defined(HAVE_LIBFFI) + struct ecl_fficall_reg * ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) { @@ -319,3 +321,5 @@ ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_typ return buf; } + +#endif diff --git a/src/c/arch/ffi_x86_64.d b/src/c/arch/ffi_x86_64.d index 4b6c6c411..7e40bb1f3 100644 --- a/src/c/arch/ffi_x86_64.d +++ b/src/c/arch/ffi_x86_64.d @@ -17,6 +17,8 @@ #include #include +#if !defined(HAVE_LIBFFI) + #define MAX_INT_REGISTERS 6 #define MAX_FP_REGISTERS 8 @@ -347,3 +349,5 @@ ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_typ return buf; } + +#endif diff --git a/src/c/ffi.d b/src/c/ffi.d index 8c69a445c..2391bd5c9 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -16,6 +16,9 @@ #include #include #include +#ifdef HAVE_LIBFFI +# include +#endif static const cl_object ecl_foreign_type_table[] = { @':char', @@ -52,10 +55,12 @@ static const cl_object ecl_foreign_type_table[] = { @':void' }; +#ifdef ECL_DYNAMIC_FFI static const cl_object ecl_foreign_cc_table[] = { @':cdecl', @':stdcall' }; +#endif static unsigned int ecl_foreign_type_size[] = { sizeof(char), @@ -92,6 +97,60 @@ static unsigned int ecl_foreign_type_size[] = { 0 }; +#ifdef HAVE_LIBFFI +static struct { + const cl_object symbol; + ffi_abi abi; +} ecl_foreign_cc_table[] = { + {@':default', FFI_DEFAULT_ABI}, +#ifdef X86_WIN32 + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':stdcall', FFI_STDCALL} +#endif +#if !defined(X86_WIN32) && (defined(__i386__) || defined(__x86_64__)) + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':unix64', FFI_UNIX64} +#endif +}; + +static ffi_type *ecl_type_to_libffi_type[] = { + &ffi_type_schar, /*@':char',*/ + &ffi_type_uchar, /*@':unsigned-char',*/ + &ffi_type_sint8, /*@':byte',*/ + &ffi_type_uint8, /*@':unsigned-byte',*/ + &ffi_type_sshort, /*@':short',*/ + &ffi_type_ushort, /*@':unsigned-short',*/ + &ffi_type_sint, /*@':int',*/ + &ffi_type_uint, /*@':unsigned-int',*/ + &ffi_type_slong, /*@':long',*/ + &ffi_type_ulong, /*@':unsigned-long',*/ +#ifdef ecl_uint16_t + &ffi_type_sint16, /*@':int16-t',*/ + &ffi_type_uint16, /*@':uint16-t',*/ +#endif +#ifdef ecl_uint32_t + &ffi_type_sint32, /*@':int64-t',*/ + &ffi_type_uint32, /*@':uint64-t',*/ +#endif +#ifdef ecl_uint64_t + &ffi_type_sint64, /*@':int64-t',*/ + &ffi_type_uint64, /*@':uint64-t',*/ +#endif +#ifdef ecl_long_long_t + &ffi_type_sint64, /*@':long-long',*/ /*FIXME! libffi does not have long long */ + &ffi_type_uint64, /*@':unsigned-long-long',*/ +#endif + &ffi_type_pointer, /*@':pointer-void',*/ + &ffi_type_pointer, /*@':cstring',*/ + &ffi_type_pointer, /*@':object',*/ + &ffi_type_float, /*@':float',*/ + &ffi_type_double, /*@':double',*/ + &ffi_type_void /*@':void'*/ +}; +#endif /* HAVE_LIBFFI */ + cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) { @@ -283,6 +342,21 @@ ecl_foreign_type_code(cl_object type) return ECL_FFI_VOID; } +#ifdef HAVE_LIBFFI +ffi_abi +ecl_foreign_cc_code(cl_object cc) +{ + int i; + for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { + if (cc == ecl_foreign_cc_table[i].symbol) + return ecl_foreign_cc_table[i].abi; + } + FEerror("~A does no denote a valid calling convention.", 1, cc); + return ECL_FFI_CC_CDECL; +} +#endif + +#ifdef ECL_DYNAMIC_FFI enum ecl_ffi_calling_convention ecl_foreign_cc_code(cl_object cc) { @@ -294,6 +368,7 @@ ecl_foreign_cc_code(cl_object cc) FEerror("~A does no denote a valid calling convention.", 1, cc); return ECL_FFI_CC_CDECL; } +#endif cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag) @@ -550,7 +625,6 @@ OUTPUT: } #ifdef ECL_DYNAMIC_FFI - static void ecl_fficall_overflow() { @@ -649,6 +723,155 @@ ecl_fficall_align(int data) si_put_sysprop(sym, @':callback', CONS(cbk, data)); @(return cbk) @) - - #endif /* ECL_DYNAMIC_FFI */ + + +#ifdef HAVE_LIBFFI +static void +resize_call_stack(cl_env_ptr env, cl_index new_size) +{ + cl_index i; + ffi_type **types = + ecl_alloc_atomic((new_size + 1) * sizeof(ffi_type*)); + union ecl_ffi_values *values = + ecl_alloc_atomic((new_size + 1) * sizeof(union ecl_ffi_values)); + union ecl_ffi_values **values_ptrs = + ecl_alloc_atomic(new_size * sizeof(union ecl_ffi_values *)); + memcpy(types, env->ffi_types, env->ffi_args_limit * sizeof(ffi_type*)); + memcpy(values, env->ffi_values, env->ffi_args_limit * + sizeof(union ecl_ffi_values)); + for (i = 0; i < new_size; i++) { + values_ptrs[i] = (values + i + 1); + } + env->ffi_args_limit = new_size; + ecl_dealloc(env->ffi_types); + env->ffi_types = types; + ecl_dealloc(env->ffi_values); + env->ffi_values = values; + ecl_dealloc(env->ffi_values_ptrs); + env->ffi_values_ptrs = values_ptrs; +} + +static int +prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, + cl_object arg_types, cl_object args, + cl_object cc_type, ffi_type ***output_copy) +{ + int n, ok; + ffi_type **types; + enum ecl_ffi_tag type = ecl_foreign_type_code(return_type); + if (!the_env->ffi_args_limit) + resize_call_stack(the_env, 32); + the_env->ffi_types[0] = ecl_type_to_libffi_type[type]; + for (n=0; !Null(arg_types); ) { + if (!LISTP(arg_types)) { + FEerror("In CALL-CFUN, types lists is not a proper list", 0); + } + if (n >= the_env->ffi_args_limit) { + resize_call_stack(the_env, n + 32); + } + type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types)); + arg_types = ECL_CONS_CDR(arg_types); + the_env->ffi_types[++n] = ecl_type_to_libffi_type[type]; + if (CONSP(args)) { + cl_object object = ECL_CONS_CAR(args); + args = ECL_CONS_CDR(args); + if (type == ECL_FFI_CSTRING) { + object = ecl_null_terminated_base_string(CAR(args)); + if (ECL_CONS_CAR(args) != object) { + ECL_STACK_PUSH(the_env, object); + } + } + ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object); + } + } + if (output_copy) { + cl_index bytes = (n + 1) * sizeof(ffi_type*); + *output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes); + memcpy(types, the_env->ffi_types, bytes); + } else { + types = the_env->ffi_types; + } + ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1); + if (ok != FFI_OK) { + if (ok == FFI_BAD_ABI) { + FEerror("In CALL-CFUN, not a valid ABI: ~A", 1, + cc_type); + } + if (ok == FFI_BAD_TYPEDEF) { + FEerror("In CALL-CFUN, wrong or malformed argument types", 0); + } + } + return n; +} + +@(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':default')) + void *cfun = ecl_foreign_data_pointer_safe(fun); + cl_object object; + volatile cl_index sp; + ffi_cif cif; +@ +{ + sp = ECL_STACK_INDEX(the_env); + prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); + ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); + object = ecl_foreign_data_ref_elt(the_env->ffi_values, + ecl_foreign_type_code(return_type)); + ECL_STACK_SET_INDEX(the_env, sp); + @(return object) +} +@) + +static void +callback_executor(ffi_cif *cif, void *result, void **args, void *userdata) +{ + cl_object data = (cl_object)userdata; + cl_object fun = ECL_CONS_CAR(data); + cl_object ret_type = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); + cl_object arg_types = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); + cl_env_ptr the_env = ecl_process_env(); + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(the_env, (cl_object)&frame_aux, 0); + cl_object x; + while (arg_types != Cnil) { + cl_object type = ECL_CONS_CAR(args); + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + x = ecl_foreign_data_ref_elt(*args, tag); + ecl_stack_frame_push(frame, x); + arg_types = ECL_CONS_CDR(arg_types); + args++; + } + x = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + ecl_foreign_data_set_elt(result, ecl_foreign_type_code(ret_type), x); +} + +@(defun si::make-dynamic-callback (fun sym return_type arg_types + &optional (cc_type @':default')) +@ +{ + ffi_cif *cif = ecl_alloc(sizeof(ffi_cif)); + ffi_type **types; + int n = prepare_cif(the_env, cif, return_type, arg_types, Cnil, cc_type, + &types); + ffi_closure *closure = ecl_alloc_atomic(sizeof(ffi_closure)); + cl_object closure_object = ecl_make_foreign_data(@':pointer-void', + sizeof(ffi_closure), + closure); + cl_object data = cl_list(6, return_type, arg_types, cc_type, + ecl_make_foreign_data(@':pointer-void', + sizeof(*cif), cif), + ecl_make_foreign_data(@':pointer-void', + (n + 1) * sizeof(ffi_type*), + types), + closure_object); + int status = ffi_prep_closure(closure, cif, callback_executor, data); + if (status != FFI_OK) { + FEerror("Unable to build callback. libffi returns ~D", 1, + MAKE_FIXNUM(status)); + } + si_put_sysprop(sym, @':callback', data); + @(return closure_object); +} +@) +#endif /* HAVE_LIBFFI */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 779f9be04..e4fc42346 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1616,7 +1616,7 @@ cl_symbols[] = { {SYS_ "*CODE-WALKER*", SI_SPECIAL, NULL, -1, OBJNULL}, -#ifdef ECL_DYNAMIC_FFI +#ifdef HAVE_LIBFFI {SYS_ "CALL-CFUN", SI_ORDINARY, si_call_cfun, -1, OBJNULL}, {KEY_ "CALLBACK", KEYWORD, NULL, -1, OBJNULL}, {SYS_ "MAKE-DYNAMIC-CALLBACK", SI_ORDINARY, si_make_dynamic_callback, -1, OBJNULL}, @@ -1796,5 +1796,8 @@ cl_symbols[] = { {SYS_ "STREAM-EXTERNAL-FORMAT-SET", SI_ORDINARY, si_stream_external_format_set, 2, OBJNULL}, +{KEY_ "SYSV", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "UNIX64", KEYWORD, NULL, -1, 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 b076fa8c8..f6597e533 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1616,7 +1616,7 @@ cl_symbols[] = { {SYS_ "*CODE-WALKER*",NULL}, -#ifdef ECL_DYNAMIC_FFI +#ifdef HAVE_LIBFFI {SYS_ "CALL-CFUN","si_call_cfun"}, {KEY_ "CALLBACK",NULL}, {SYS_ "MAKE-DYNAMIC-CALLBACK","si_make_dynamic_callback"}, @@ -1796,5 +1796,8 @@ cl_symbols[] = { {SYS_ "STREAM-EXTERNAL-FORMAT-SET","si_stream_external_format_set"}, +{KEY_ "SYSV",NULL}, +{KEY_ "UNIX64",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/configure b/src/configure index 6a6406bfa..28e745a6f 100755 --- a/src/configure +++ b/src/configure @@ -4730,6 +4730,81 @@ _ACEOF fi # on IRIX adds -lsun + +{ $as_echo "$as_me:$LINENO: checking for ffi_call in -lffi" >&5 +$as_echo_n "checking for ffi_call in -lffi... " >&6; } +if test "${ac_cv_lib_ffi_ffi_call+set}" = set; then + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lffi $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char ffi_call (); +int +main () +{ +return ffi_call (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" +$as_echo "$ac_try_echo") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + $as_test_x conftest$ac_exeext + }; then + ac_cv_lib_ffi_ffi_call=yes +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_lib_ffi_ffi_call=no +fi + +rm -rf conftest.dSYM +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_ffi_ffi_call" >&5 +$as_echo "$ac_cv_lib_ffi_ffi_call" >&6; } +if test "x$ac_cv_lib_ffi_ffi_call" = x""yes; then + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBFFI 1 +_ACEOF + + LIBS="-lffi $LIBS" + +fi + { $as_echo "$as_me:$LINENO: checking for library containing strerror" >&5 $as_echo_n "checking for library containing strerror... " >&6; } if test "${ac_cv_search_strerror+set}" = set; then diff --git a/src/configure.in b/src/configure.in index 65d7de9b4..226caa04d 100644 --- a/src/configure.in +++ b/src/configure.in @@ -319,6 +319,7 @@ dnl Checks for libraries LIBS="${LIBS} -lm" AC_CHECK_LIB(sun, getpwnam) # on IRIX adds -lsun +AC_CHECK_LIB(ffi, ffi_call) AC_ISC_POSIX dnl ---------------------------------------------------------------------- diff --git a/src/h/config.h.in b/src/h/config.h.in index 60ae4e34d..bc90984cb 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -90,8 +90,14 @@ /* Stack grows downwards */ #undef ECL_DOWN_STACK +/* We have libffi and can use it */ +#undef HAVE_LIBFFI + /* We have non-portable implementation of FFI calls */ +/* Only used as a last resort, when libffi is missin */ +#ifndef HAVE_LIBFFI #undef ECL_DYNAMIC_FFI +#endif /* We use hierarchical package names, like in Allegro CL */ #undef ECL_RELATIVE_PACKAGE_NAMES diff --git a/src/h/external.h b/src/h/external.h index f971d0128..15e5f76e2 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -115,7 +115,15 @@ struct cl_env_struct { #endif /* foreign function interface */ - void *fficall; +#ifdef HAVE_LIBFFI + cl_index ffi_args_limit; + struct _ffi_type **ffi_types; + union ecl_ffi_values *ffi_values; + union ecl_ffi_values **ffi_values_ptrs; +#endif +#ifdef ECL_DYNAMIC_FFI + void *fficall; +#endif /* Alternative stack for processing signals */ void *altstack; diff --git a/src/h/internal.h b/src/h/internal.h index 28f3dd6ed..1595af9da 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -178,6 +178,7 @@ struct ecl_fficall { }; extern enum ecl_ffi_tag ecl_foreign_type_code(cl_object type); +#ifdef ECL_DYNAMIC_FFI extern enum ecl_ffi_calling_convention ecl_foreign_cc_code(cl_object cc_type); extern void ecl_fficall_prepare(cl_object return_type, cl_object arg_types, cl_object cc_type); extern void ecl_fficall_push_bytes(void *data, size_t bytes); @@ -189,6 +190,7 @@ extern void ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag ty extern void ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type); extern void ecl_dynamic_callback_call(cl_object callback_info, char* buffer); extern void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type); +#endif /* file.d */