From 7dbde99b7cf38814a3862ff1a8647fcfd3ae7fdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 27 Nov 2019 15:33:24 +0100 Subject: [PATCH] ffi: defcallback: unify behavior of dffi and compiled versions - normalize return-type from NIL to :void, ARRAY and '* in interpreted dffi implementation -- it is already normalized in sffi - remove invalid path where argument type was not a valid elementary FFI type when it was not c1-defcallback pushed result of add-object to arg-type-constants and tried to pass the data as opaque pointers. That said it could never work, because: 1. add-object could return a string (i.e for known symbols expanding to ECL_SYM) and they were fed as elementary FFI type leading to errors during compilation by C compiler (invalid enum type) 2. when ecl_make_foreign_data was called to pass opaque objects a function FFI:SIZE-OF-FOREIGN-TYPE was called which resulted in error (because return type is not a valid elementary FFI type what this code path was meant to be) Moreover we validate both return type and argument types during the first compiler to fail as early as possible (previously only argument types were validated early). - some cosmetic fixes like indentation or redundant PROGN --- src/cmp/cmpcbk.lsp | 73 +++++++++++++++++++++------------------------- src/lsp/ffi.lsp | 6 +++- 2 files changed, 38 insertions(+), 41 deletions(-) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 79e8a2773..2cb1d9396 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -48,12 +48,17 @@ (defun foreign-elt-type-code (type) (let ((x (assoc type +foreign-elt-type-codes+))) (unless x - (cmperr "~a is not a valid elementary FFI type" type)) + (cmperr "DEFCALLBACK: ~a is not a valid elementary FFI type." type)) (cdr x))) (defun c1-defcallback (args) (destructuring-bind (name return-type arg-list &rest body) args + (cond ((eql return-type nil) + (setf return-type :void)) + ((and (consp return-type) + (member (first return-type) '(* array))) + (setf return-type :pointer-void))) (let ((arg-types '()) (arg-type-constants '()) (arg-variables '()) @@ -65,34 +70,27 @@ (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) (push (first i) arg-variables) (let ((type (second i))) - (push (second i) arg-types) - (push (if (ffi::foreign-elt-type-p type) - (foreign-elt-type-code type) - (add-object type)) - arg-type-constants))) + (push type arg-types) + (push (foreign-elt-type-code type) arg-type-constants))) (push (list name c-name (add-object name) - return-type (reverse arg-types) (reverse arg-type-constants) call-type) + return-type + (foreign-elt-type-code return-type) + (reverse arg-types) + (reverse arg-type-constants) + call-type) *callbacks*) (c1expr `(progn - (defun ,name ,(reverse arg-variables) ,@body) - (si:put-sysprop ',name :callback - (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) - :one-liner t))))))) + (defun ,name ,(reverse arg-variables) ,@body) + (si:put-sysprop ',name :callback + (ffi:c-inline () () :object + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) + :one-liner t))))))) - -(defun t3-defcallback (lisp-name c-name c-name-constant return-type +(defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code arg-types arg-type-constants call-type &aux (return-p t)) - (cond ((member return-type '(nil :void)) - (setf return-p nil)) - ((ffi::foreign-elt-type-p return-type)) - ((and (consp return-type) - (member (first return-type) '(* array))) - (setf return-type :pointer-void)) - (t - (cmperr "DEFCALLBACK does not support complex return types such as ~A" - return-type))) + (when (eql return-type :void) + (setf return-p nil)) (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) (fmod (case call-type ((:cdecl :default) "") @@ -100,15 +98,14 @@ (t (cmperr "DEFCALLBACK does not support ~A as calling convention" call-type))))) (wt-nl-h "static " return-type-name " " fmod c-name "(") - (wt-nl1 "static " return-type-name " " fmod c-name "(") - (loop for n from 0 - and type in arg-types - with comma = "" - do - (progn - (wt-h comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (wt comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (setf comma ","))) + (wt-nl1 "static " return-type-name " " fmod c-name "(") + (loop with comma = "" + for n from 0 + for type in arg-types + for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type)) + do (wt-h comma arg-type-name " var" n) + (wt comma arg-type-name " var" n) + (setf comma ",")) (wt ")") (wt-h ");") (wt-nl-open-brace) @@ -120,17 +117,13 @@ (loop for n from 0 and type in arg-types and ct in arg-type-constants - do - (if (stringp ct) - (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" - n "," ct "));") - (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" - n "," ct ", (void*)" (ffi:size-of-foreign-type type) "));"))) + do (wt-nl "ecl_stack_frame_push(" + "frame,ecl_foreign_data_ref_elt(" "&var" n "," ct ")" + ");")) (wt-nl "aux = ecl_apply_from_stack_frame(frame," "ecl_fdefinition(" c-name-constant "));") (wt-nl "ecl_stack_frame_close(frame);") (when return-p - (wt-nl "ecl_foreign_data_set_elt(&output," - (foreign-elt-type-code return-type) ",aux);") + (wt-nl "ecl_foreign_data_set_elt(&output," return-type-code ",aux);") (wt-nl "return output;")) (wt-nl-close-brace))) diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index d4e289e2c..670797bfa 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -761,7 +761,11 @@ Loads a foreign library." (values-list name) (values name :default)) (let ((arg-types (mapcar #'second arg-desc)) - (arg-names (mapcar #'first arg-desc))) + (arg-names (mapcar #'first arg-desc)) + (ret-type (typecase ret-type + ((member nil :void) :void) + ((cons (member * array)) :pointer-void) + (otherwise ret-type)))) `(si::make-dynamic-callback #'(ext::lambda-block ,name ,arg-names ,@body) ',name ',ret-type ',arg-types ,call-type)))