mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-24 05:21:20 -08:00
Code Issues Projects Releases Packages Wiki Activity

ffi: defcallback: unify behavior of dffi and compiled versions

Browse source 
- 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
This commit is contained in:
Daniel Kochmański 2019-11-27 15:33:24 +01:00
parent 83ec2c86c7
commit 7dbde99b7c
2 changed files with 38 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

73
src/cmp/cmpcbk.lsp
View file

@ -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)))

6
src/lsp/ffi.lsp
View file

@ -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)))