diff --git a/src/c/arch/ffi_x86.d b/src/c/arch/ffi_x86.d index f8364badc..7cafa7994 100644 --- a/src/c/arch/ffi_x86.d +++ b/src/c/arch/ffi_x86.d @@ -91,11 +91,14 @@ ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag r } else { ((void (*)())f_ptr)(); } + + if (fficall->cc == ECL_FFI_CC_CDECL) { #ifdef _MSC_VER - __asm add esp,bufsize + __asm add esp,bufsize #else - sp += fficall->buffer_size; + sp += fficall->buffer_size; #endif + } } static void @@ -182,7 +185,7 @@ INT: } void* -ecl_dynamic_callback_make(cl_object data) +ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type) { /* * push %esp 54 @@ -203,8 +206,23 @@ ecl_dynamic_callback_make(cl_object data) *(long*) (buf+7) = (long)ecl_dynamic_callback_execute - (long)(buf+11); *(char*) (buf+11) = 0x59; *(char*) (buf+12) = 0x59; - *(char*) (buf+13) = 0xc3; - *(short*)(buf+14) = 0x9090; + if (cc_type == ECL_FFI_CC_CDECL) { + *(char*) (buf+13) = 0xc3; + *(short*)(buf+14) = 0x9090; + } else { + cl_object arg_types = CADDR(data); + int byte_size = 0; + int mask = 3; + + while (CONSP(arg_types)) { + int sz = fix(si_size_of_foreign_elt_type(CAR(arg_types))); + byte_size += ((sz+mask)&(~mask)); + arg_types = CDR(arg_types); + } + + *(char*) (buf+13) = 0xc2; + *(short*)(buf+14) = (short)byte_size; + } return buf; } diff --git a/src/c/ffi.d b/src/c/ffi.d index 7be36ac24..dac3dc864 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -34,6 +34,11 @@ static const cl_object ecl_foreign_type_table[] = { @':double', @':void'}; +static const cl_object ecl_foreign_cc_table[] = { + @':cdecl', + @':stdcall' +}; + static unsigned int ecl_foreign_type_size[] = { sizeof(char), sizeof(unsigned char), @@ -219,6 +224,18 @@ ecl_foreign_type_code(cl_object type) return ECL_FFI_VOID; } +enum ecl_ffi_calling_convention +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]) + return (enum ecl_ffi_calling_convention)i; + } + FEerror("~A does no denote a valid calling convention.", 1, cc); + return ECL_FFI_CC_CDECL; +} + cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag) { @@ -438,12 +455,13 @@ ecl_fficall_overflow() } void -ecl_fficall_prepare(cl_object return_type, cl_object arg_type) +ecl_fficall_prepare(cl_object return_type, cl_object arg_type, cl_object cc_type) { struct ecl_fficall *fficall = cl_env.fficall; fficall->buffer_sp = fficall->buffer; fficall->buffer_size = 0; fficall->cstring = Cnil; + fficall->cc = ecl_foreign_cc_code(cc_type); } void @@ -480,16 +498,14 @@ ecl_fficall_align(int data) } } -cl_object -si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types, - cl_object args) -{ +@(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':cdecl')) 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); + ecl_fficall_prepare(return_type, arg_types, cc_type); while (CONSP(arg_types)) { enum ecl_ffi_tag type; if (!CONSP(args)) { @@ -517,17 +533,18 @@ si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types, fficall->cstring = Cnil; @(return object) -} +@) -cl_object -si_make_dynamic_callback(cl_object fun, cl_object sym, cl_object rtype, cl_object argtypes) -{ - cl_object data = CONS(fun, CONS(rtype, CONS(argtypes, Cnil))); - cl_object cbk = ecl_make_foreign_data(@':pointer-void', 0, ecl_dynamic_callback_make(data)); +@(defun si::make-dynamic-callback (fun sym rtype argtypes &optional (cctype @':cdecl')) + cl_object data; + cl_object cbk; +@ + data = CONS(fun, CONS(rtype, CONS(argtypes, Cnil))); + cbk = ecl_make_foreign_data(@':pointer-void', 0, ecl_dynamic_callback_make(data, ecl_foreign_cc_code(cctype))); si_put_sysprop(sym, @':callback', CONS(cbk, data)); @(return cbk) -} +@) #endif /* ECL_DYNAMIC_FFI */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 020f53167..eb2b8723d 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1553,10 +1553,12 @@ cl_symbols[] = { {SYS_ "*CODE-WALKER*", SI_SPECIAL, NULL, -1, OBJNULL}, #ifdef ECL_DYNAMIC_FFI -{SYS_ "CALL-CFUN", SI_ORDINARY, si_call_cfun, 4, OBJNULL}, +{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, 4, OBJNULL}, +{SYS_ "MAKE-DYNAMIC-CALLBACK", SI_ORDINARY, si_make_dynamic_callback, -1, OBJNULL}, #endif +{KEY_ "CDECL", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "STDCALL", 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 6808476c2..a76f12739 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1552,10 +1552,14 @@ cl_symbols[] = { {SYS_ "*CODE-WALKER*",NULL}, +#ifdef ECL_DYNAMIC_FFI {SYS_ "CALL-CFUN","si_call_cfun"}, {KEY_ "CALLBACK",NULL}, - {SYS_ "MAKE-DYNAMIC-CALLBACK","si_make_dynamic_callback"}, +#endif +{KEY_ "CDECL",NULL}, +{KEY_ "STDCALL",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 1f0bb4420..56e89e5b3 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -17,7 +17,9 @@ (let ((arg-types '()) (arg-type-constants '()) (arg-variables '()) - (c-name (format nil "ecl_callback_~d" (length *callbacks*)))) + (c-name (format nil "ecl_callback_~d" (length *callbacks*))) + (name (if (consp name) (first name) name)) + (call-type (if (consp name) (second name) :cdecl))) (dolist (i arg-list) (unless (consp i) (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) @@ -29,7 +31,7 @@ (add-object type)) arg-type-constants))) (push (list name c-name (add-object name) - return-type (reverse arg-types) (reverse arg-type-constants)) + return-type (reverse arg-types) (reverse arg-type-constants) call-type) *callbacks*) (c1expr `(progn @@ -66,7 +68,7 @@ (cdr x))) (defun t3-defcallback (lisp-name c-name c-name-constant return-type - arg-types arg-type-constants) + arg-types arg-type-constants call-type) (cond ((ffi::foreign-elt-type-p return-type)) ((and (consp return-type) (member (first return-type) '(* array))) @@ -74,8 +76,13 @@ (t (cmperr "DEFCALLBACK does not support complex return types such as ~A" return-type))) - (let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type)))) - (wt-nl1 return-type-name " " c-name "(") + (let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type))) + (fmod (case call-type + (:cdecl "") + (:stdcall "__stdcall ") + (t (cmperr "DEFCALLBACK does not support ~A as calling convention" + call-type))))) + (wt-nl1 return-type-name " " fmod c-name "(") (loop for n from 0 and type in arg-types with comma = "" diff --git a/src/h/internal.h b/src/h/internal.h index 5d8d84006..964da411f 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -109,16 +109,23 @@ union ecl_ffi_values { double d; }; +enum ecl_ffi_calling_convention { + ECL_FFI_CC_CDECL = 0, + ECL_FFI_CC_STDCALL +}; + struct ecl_fficall { char *buffer_sp; size_t buffer_size; union ecl_ffi_values output; + enum ecl_ffi_calling_conventions cc; 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); +enum ecl_ffi_calling_convention ecl_foreign_cc_code(cl_object cc_type); +void ecl_fficall_prepare(cl_object return_type, cl_object arg_types, cl_object cc_type); void ecl_fficall_push_bytes(void *data, size_t bytes); void ecl_fficall_push_int(int word); void ecl_fficall_align(int data); @@ -128,7 +135,7 @@ 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); void ecl_dynamic_callback_call(cl_object callback_info, char* buffer); -void* ecl_dynamic_callback_make(cl_object data); +void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type); /* file.d */ diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 8b1197e50..b270afdaf 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -511,7 +511,7 @@ ;;; FIXME! We should turn this into a closure generator that produces no code. #+DFFI -(defmacro def-lib-function (name args &key returning module) +(defmacro def-lib-function (name args &key returning module (call :cdecl)) (multiple-value-bind (c-name lisp-name) (if (consp name) (values-list name) (values (string name) name)) @@ -520,13 +520,13 @@ (argtypes (mapcar #'(lambda (a) (ffi::%convert-to-arg-type (second a))) args))) `(let ((c-fun (si::find-foreign-symbol ,c-name ,module :pointer-void 0))) (defun ,lisp-name ,(mapcar #'first args) - (si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args)))))))) + (si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args)) ,call)))))) -(defmacro def-function (name args &key module (returning :void)) +(defmacro def-function (name args &key module (returning :void) (call :cdecl)) #+DFFI (when module (return-from def-function - `(def-lib-function ,name ,args :returning ,returning :module ,module))) + `(def-lib-function ,name ,args :returning ,returning :module ,module :call ,call))) (multiple-value-bind (c-name lisp-name) (lisp-to-c-name name) (let* ((arguments (mapcar #'first args)) @@ -640,11 +640,14 @@ #+dffi (defmacro defcallback (name ret-type arg-desc &body body) - (let ((arg-types (mapcar #'second arg-desc)) - (arg-names (mapcar #'first arg-desc))) - `(si::make-dynamic-callback - #'(ext::lambda-block ,name ,arg-names ,@body) - ',name ',ret-type ',arg-types))) + (multiple-value-bind (name call-type) (if (consp name) + (values-list name) + (values name :cdecl)) + (let ((arg-types (mapcar #'second arg-desc)) + (arg-names (mapcar #'first arg-desc))) + `(si::make-dynamic-callback + #'(ext::lambda-block ,name ,arg-names ,@body) + ',name ',ret-type ',arg-types ,call-type)))) (defun callback (name) (let ((x (si::get-sysprop name :callback)))