1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
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:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
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.
30 (defpackage #:cffi-sys
31 (:use
#:common-lisp
#:sb-alien
#:cffi-utils
)
33 #:canonicalize-symbol-name-case
44 #:with-foreign-pointer
46 #:%foreign-funcall-pointer
47 #:%foreign-type-alignment
49 #:%load-foreign-library
50 #:%close-foreign-library
54 #:make-shareable-byte-vector
55 #:with-pointer-to-vector-data
56 #:%foreign-symbol-pointer
60 (in-package #:cffi-sys
)
64 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
65 (mapc (lambda (feature) (pushnew feature
*features
*))
67 #+darwin cffi-features
:darwin
68 #+(and unix
(not win32
)) cffi-features
:unix
69 #+win32 cffi-features
:windows
70 #+x86 cffi-features
:x86
71 #+x86-64 cffi-features
:x86-64
72 #+(and ppc
(not ppc64
)) cffi-features
:ppc32
74 cffi-features
:flat-namespace
79 (declaim (inline canonicalize-symbol-name-case
))
80 (defun canonicalize-symbol-name-case (name)
81 (declare (string name
))
84 ;;;# Basic Pointer Operations
86 (deftype foreign-pointer
()
87 'sb-sys
:system-area-pointer
)
89 (declaim (inline pointerp
))
91 "Return true if PTR is a foreign pointer."
92 (sb-sys:system-area-pointer-p ptr
))
94 (declaim (inline pointer-eq
))
95 (defun pointer-eq (ptr1 ptr2
)
96 "Return true if PTR1 and PTR2 point to the same address."
97 (declare (type system-area-pointer ptr1 ptr2
))
98 (sb-sys:sap
= ptr1 ptr2
))
100 (declaim (inline null-pointer
))
101 (defun null-pointer ()
102 "Construct and return a null pointer."
105 (declaim (inline null-pointer-p
))
106 (defun null-pointer-p (ptr)
107 "Return true if PTR is a null pointer."
108 (declare (type system-area-pointer ptr
))
109 (zerop (sb-sys:sap-int ptr
)))
111 (declaim (inline inc-pointer
))
112 (defun inc-pointer (ptr offset
)
113 "Return a pointer pointing OFFSET bytes past PTR."
114 (declare (type system-area-pointer ptr
)
115 (type integer offset
))
116 (sb-sys:sap
+ ptr offset
))
118 (declaim (inline make-pointer
))
119 (defun make-pointer (address)
120 "Return a pointer pointing to ADDRESS."
121 ;; (declare (type (unsigned-byte 32) address))
122 (sb-sys:int-sap address
))
124 (declaim (inline pointer-address
))
125 (defun pointer-address (ptr)
126 "Return the address pointed to by PTR."
127 (declare (type system-area-pointer ptr
))
128 (sb-sys:sap-int ptr
))
132 ;;; Functions and macros for allocating foreign memory on the stack
133 ;;; and on the heap. The main CFFI package defines macros that wrap
134 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
135 ;;; when the memory has dynamic extent.
137 (declaim (inline %foreign-alloc
))
138 (defun %foreign-alloc
(size)
139 "Allocate SIZE bytes on the heap and return a pointer."
140 ;; (declare (type (unsigned-byte 32) size))
141 (alien-sap (make-alien (unsigned 8) size
)))
143 (declaim (inline foreign-free
))
144 (defun foreign-free (ptr)
145 "Free a PTR allocated by FOREIGN-ALLOC."
146 (declare (type system-area-pointer ptr
))
147 (free-alien (sap-alien ptr
(* (unsigned 8)))))
149 (defmacro with-foreign-pointer
((var size
&optional size-var
) &body body
)
150 "Bind VAR to SIZE bytes of foreign memory during BODY. The
151 pointer in VAR is invalid beyond the dynamic extent of BODY, and
152 may be stack-allocated if supported by the implementation. If
153 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
155 (setf size-var
(gensym "SIZE")))
156 ;; If the size is constant we can stack-allocate.
158 (let ((alien-var (gensym "ALIEN")))
159 `(with-alien ((,alien-var
(array (unsigned 8) ,(eval size
))))
160 (let ((,size-var
,(eval size
))
161 (,var
(alien-sap ,alien-var
)))
162 (declare (ignorable ,size-var
))
164 `(let* ((,size-var
,size
)
165 (,var
(%foreign-alloc
,size-var
)))
168 (foreign-free ,var
)))))
170 ;;;# Shareable Vectors
172 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
173 ;;; should be defined to perform a copy-in/copy-out if the Lisp
174 ;;; implementation can't do this.
176 (declaim (inline make-shareable-byte-vector
))
177 (defun make-shareable-byte-vector (size)
178 "Create a Lisp vector of SIZE bytes can passed to
179 WITH-POINTER-TO-VECTOR-DATA."
180 ; (declare (type sb-int:index size))
181 (make-array size
:element-type
'(unsigned-byte 8)))
183 (defmacro with-pointer-to-vector-data
((ptr-var vector
) &body body
)
184 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
185 (let ((vector-var (gensym "VECTOR")))
186 `(let ((,vector-var
,vector
))
187 (declare (type (sb-kernel:simple-unboxed-array
(*)) ,vector-var
))
188 (sb-sys:with-pinned-objects
(,vector-var
)
189 (let ((,ptr-var
(sb-sys:vector-sap
,vector-var
)))
194 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
195 ;;; macros that optimize the case where the type keyword is constant
197 (defmacro define-mem-accessors
(&body pairs
)
199 (defun %mem-ref
(ptr type
&optional
(offset 0))
201 ,@(loop for
(keyword fn
) in pairs
202 collect
`(,keyword
(,fn ptr offset
)))))
203 (defun %mem-set
(value ptr type
&optional
(offset 0))
205 ,@(loop for
(keyword fn
) in pairs
206 collect
`(,keyword
(setf (,fn ptr offset
) value
)))))
207 (define-compiler-macro %mem-ref
208 (&whole form ptr type
&optional
(offset 0))
211 ,@(loop for
(keyword fn
) in pairs
212 collect
`(,keyword
`(,',fn
,ptr
,offset
))))
214 (define-compiler-macro %mem-set
215 (&whole form value ptr type
&optional
(offset 0))
219 ,@(loop for
(keyword fn
) in pairs
220 collect
`(,keyword
`(setf (,',fn
,ptr
,offset
)
224 (define-mem-accessors
225 (:char sb-sys
:signed-sap-ref-8
)
226 (:unsigned-char sb-sys
:sap-ref-8
)
227 (:short sb-sys
:signed-sap-ref-16
)
228 (:unsigned-short sb-sys
:sap-ref-16
)
229 (:int sb-sys
:signed-sap-ref-32
)
230 (:unsigned-int sb-sys
:sap-ref-32
)
231 (:long sb-sys
:signed-sap-ref-word
)
232 (:unsigned-long sb-sys
:sap-ref-word
)
233 (:long-long sb-sys
:signed-sap-ref-64
)
234 (:unsigned-long-long sb-sys
:sap-ref-64
)
235 (:float sb-sys
:sap-ref-single
)
236 (:double sb-sys
:sap-ref-double
)
237 (:pointer sb-sys
:sap-ref-sap
))
239 ;;;# Calling Foreign Functions
241 (defun convert-foreign-type (type-keyword)
242 "Convert a CFFI type keyword to an SB-ALIEN type."
245 (:unsigned-char
'unsigned-char
)
247 (:unsigned-short
'unsigned-short
)
249 (:unsigned-int
'unsigned-int
)
251 (:unsigned-long
'unsigned-long
)
252 (:long-long
'long-long
)
253 (:unsigned-long-long
'unsigned-long-long
)
254 (:float
'single-float
)
255 (:double
'double-float
)
256 (:pointer
'system-area-pointer
)
259 (defun %foreign-type-size
(type-keyword)
260 "Return the size in bytes of a foreign type."
261 (/ (sb-alien-internals:alien-type-bits
262 (sb-alien-internals:parse-alien-type
263 (convert-foreign-type type-keyword
) nil
)) 8))
265 (defun %foreign-type-alignment
(type-keyword)
266 "Return the alignment in bytes of a foreign type."
267 #+(and darwin ppc
(not ppc64
))
269 ((:double
:long-long
:unsigned-long-long
)
270 (return-from %foreign-type-alignment
8)))
271 ;; No override necessary for other types...
272 (/ (sb-alien-internals:alien-type-alignment
273 (sb-alien-internals:parse-alien-type
274 (convert-foreign-type type-keyword
) nil
)) 8))
276 (defun foreign-funcall-type-and-args (args)
277 "Return an SB-ALIEN function type for ARGS."
278 (let ((return-type 'void
))
279 (loop for
(type arg
) on args by
#'cddr
280 if arg collect
(convert-foreign-type type
) into types
281 and collect arg into fargs
282 else do
(setf return-type
(convert-foreign-type type
))
283 finally
(return (values types fargs return-type
)))))
285 (defmacro %%foreign-funcall
(name types fargs rettype
)
286 "Internal guts of %FOREIGN-FUNCALL."
288 (extern-alien ,name
(function ,rettype
,@types
))
291 (defmacro %foreign-funcall
(name args
&key library calling-convention
)
292 "Perform a foreign function call, document it more later."
293 (declare (ignore library calling-convention
))
294 (multiple-value-bind (types fargs rettype
)
295 (foreign-funcall-type-and-args args
)
296 `(%%foreign-funcall
,name
,types
,fargs
,rettype
)))
298 (defmacro %foreign-funcall-pointer
(ptr args
&key calling-convention
)
299 "Funcall a pointer to a foreign function."
300 (declare (ignore calling-convention
))
301 (multiple-value-bind (types fargs rettype
)
302 (foreign-funcall-type-and-args args
)
303 (with-unique-names (function)
304 `(with-alien ((,function
(* (function ,rettype
,@types
)) ,ptr
))
305 (alien-funcall ,function
,@fargs
)))))
309 ;;; The *CALLBACKS* hash table contains a direct mapping of CFFI
310 ;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA.
311 ;;; SBCL will maintain the addresses of the callbacks across saved
312 ;;; images, so it is safe to store the pointers directly.
313 (defvar *callbacks
* (make-hash-table))
315 (defmacro %defcallback
(name rettype arg-names arg-types body
316 &key calling-convention
)
317 (declare (ignore calling-convention
))
318 `(setf (gethash ',name
*callbacks
*)
320 (sb-alien::alien-lambda
,(convert-foreign-type rettype
)
321 ,(mapcar (lambda (sym type
)
322 (list sym
(convert-foreign-type type
)))
326 (defun %callback
(name)
327 (or (gethash name
*callbacks
*)
328 (error "Undefined callback: ~S" name
)))
330 ;;;# Loading and Closing Foreign Libraries
332 (declaim (inline %load-foreign-library
))
333 (defun %load-foreign-library
(name path
)
334 "Load a foreign library."
335 (declare (ignore name
))
336 (load-shared-object path
))
338 (defun %close-foreign-library
(handle)
339 "Closes a foreign library."
340 (sb-alien::dlclose-or-lose
341 (find (sb-ext:native-namestring handle
) sb-alien
::*shared-objects
*
342 :key
#'sb-alien
::shared-object-file
345 (defun native-namestring (pathname)
346 (sb-ext:native-namestring pathname
))
350 (defun %foreign-symbol-pointer
(name library
)
351 "Returns a pointer to a foreign symbol NAME."
352 (declare (ignore library
))
353 (let-when (address (sb-sys:find-foreign-symbol-address name
))
354 (sb-sys:int-sap address
)))