try to translate constant enum keywords at compile time
[cffi.git] / libffi / funcall.lisp
blob3aa52ec5a7946ff488aaccf8394511be7dd47f14
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; funcall.lisp -- FOREIGN-FUNCALL implementation using libffi
4 ;;;
5 ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy <lhealy@common-lisp.net>
6 ;;;
7 ;;; Permission is hereby granted, free of charge, to any person
8 ;;; obtaining a copy of this software and associated documentation
9 ;;; files (the "Software"), to deal in the Software without
10 ;;; restriction, including without limitation the rights to use, copy,
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12 ;;; of the Software, and to permit persons to whom the Software is
13 ;;; furnished to do so, subject to the following conditions:
14 ;;;
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
17 ;;;
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25 ;;; DEALINGS IN THE SOFTWARE.
26 ;;;
28 (in-package #:cffi)
30 (define-condition libffi-error (cffi-error)
31 ((function-name
32 :initarg :function-name :reader function-name)))
34 (define-condition simple-libffi-error (simple-error libffi-error)
35 ())
37 (defun libffi-error (function-name format-control &rest format-arguments)
38 (error 'simple-libffi-error
39 :function-name function-name
40 :format-control format-control
41 :format-arguments format-arguments))
43 (defun make-libffi-cif (function-name return-type argument-types
44 &optional (abi :default-abi))
45 "Generate or retrieve the Call InterFace needed to call the function through libffi."
46 (let* ((argument-count (length argument-types))
47 (cif (foreign-alloc '(:struct ffi-cif)))
48 (ffi-argtypes (foreign-alloc :pointer :count argument-count)))
49 (loop
50 :for type :in argument-types
51 :for index :from 0
52 :do (setf (mem-aref ffi-argtypes :pointer index)
53 (make-libffi-type-descriptor (parse-type type))))
54 (unless (eql :ok (libffi/prep-cif cif abi argument-count
55 (make-libffi-type-descriptor (parse-type return-type))
56 ffi-argtypes))
57 (libffi-error function-name
58 "The 'ffi_prep_cif' libffi call failed for function ~S."
59 function-name))
60 cif))
62 (defun free-libffi-cif (ptr)
63 (foreign-free (foreign-slot-value ptr '(:struct ffi-cif) 'argument-types))
64 (foreign-free ptr))
66 (defun translate-objects-ret (symbols function-arguments types return-type call-form)
67 (translate-objects
68 symbols
69 function-arguments
70 types
71 return-type
72 (if (or (eql return-type :void)
73 (typep (parse-type return-type) 'translatable-foreign-type))
74 call-form
75 ;; built-in types won't be translated by
76 ;; expand-from-foreign, we have to do it here
77 `(mem-ref
78 ,call-form
79 ',(canonicalize-foreign-type return-type)))
80 t))
82 (defun foreign-funcall-form/fsbv-with-libffi (function function-arguments symbols types
83 return-type argument-types
84 &optional pointerp (abi :default-abi))
85 "A body of foreign-funcall calling the libffi function #'call (ffi_call)."
86 (let ((argument-count (length argument-types)))
87 `(with-foreign-objects ((argument-values :pointer ,argument-count)
88 ,@(unless (eql return-type :void)
89 `((result ',return-type))))
90 ,(translate-objects-ret
91 symbols function-arguments types return-type
92 ;; NOTE: We must delay the cif creation until the first call
93 ;; because it's FOREIGN-ALLOC'd, i.e. it gets corrupted by an
94 ;; image save/restore cycle. This way a lib will remain usable
95 ;; through a save/restore cycle if the save happens before any
96 ;; FFI calls will have been made, i.e. nothing is malloc'd yet.
97 `(progn
98 (loop
99 :for arg :in (list ,@symbols)
100 :for count :from 0
101 :do (setf (mem-aref argument-values :pointer count) arg))
102 (let* ((libffi-cif-cache (load-time-value (cons 'libffi-cif-cache nil)))
103 (libffi-cif (or (cdr libffi-cif-cache)
104 ;; TODO use compare-and-swap to set it, and call
105 ;; FREE-LIBFFI-CIF if it was set by another
106 ;; thread before us.
107 (setf (cdr libffi-cif-cache)
108 ;; FIXME we should install a finalizer on the cons cell
109 ;; that calls FREE-LIBFFI-CIF on the cif (when the function
110 ;; gets redefined, and the cif becomes unreachable). but a
111 ;; finite world is full of compromises... - attila
112 (make-libffi-cif ,function ',return-type
113 ',argument-types ',abi)))))
114 (libffi/call libffi-cif
115 ,(if pointerp
116 function
117 `(foreign-symbol-pointer ,function))
118 ,(if (eql return-type :void) '(null-pointer) 'result)
119 argument-values)
120 ,(if (eql return-type :void)
121 '(values)
122 'result)))))))
124 (setf *foreign-structures-by-value* 'foreign-funcall-form/fsbv-with-libffi)
126 ;; DEPRECATED Its presence encourages the use of #+fsbv which may lead to the
127 ;; situation where a fasl was produced by an image that has fsbv feature
128 ;; and then ends up being loaded into an image later that has no fsbv support
129 ;; loaded. Use explicit ASDF dependencies instead and assume the presence
130 ;; of the feature accordingly.
131 (pushnew :fsbv *features*)
133 ;; DEPRECATED This is here only for backwards compatibility until its fate is
134 ;; decided. See the mailing list discussion for details.
135 (defctype :sizet size-t)