1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; cffi-cmucl.lisp --- CFFI-SYS implementation for CMU CL.
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
#:alien
#:c-call
#: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 #+unix cffi-features
:unix
69 #+x86 cffi-features
:x86
70 #+(and ppc
(not ppc64
)) cffi-features
:ppc32
72 cffi-features
:flat-namespace
77 (defun canonicalize-symbol-name-case (name)
78 (declare (string name
))
81 ;;;# Basic Pointer Operations
83 (deftype foreign-pointer
()
84 'sys
:system-area-pointer
)
86 (declaim (inline pointerp
))
88 "Return true if PTR is a foreign pointer."
89 (sys:system-area-pointer-p ptr
))
91 (declaim (inline pointer-eq
))
92 (defun pointer-eq (ptr1 ptr2
)
93 "Return true if PTR1 and PTR2 point to the same address."
96 (declaim (inline null-pointer
))
97 (defun null-pointer ()
98 "Construct and return a null pointer."
101 (declaim (inline null-pointer-p
))
102 (defun null-pointer-p (ptr)
103 "Return true if PTR is a null pointer."
104 (zerop (sys:sap-int ptr
)))
106 (declaim (inline inc-pointer
))
107 (defun inc-pointer (ptr offset
)
108 "Return a pointer pointing OFFSET bytes past PTR."
109 (sys:sap
+ ptr offset
))
111 (declaim (inline make-pointer
))
112 (defun make-pointer (address)
113 "Return a pointer pointing to ADDRESS."
114 (sys:int-sap address
))
116 (declaim (inline pointer-address
))
117 (defun pointer-address (ptr)
118 "Return the address pointed to by PTR."
121 (defmacro with-foreign-pointer
((var size
&optional size-var
) &body body
)
122 "Bind VAR to SIZE bytes of foreign memory during BODY. The
123 pointer in VAR is invalid beyond the dynamic extent of BODY, and
124 may be stack-allocated if supported by the implementation. If
125 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
127 (setf size-var
(gensym "SIZE")))
128 ;; If the size is constant we can stack-allocate.
130 (let ((alien-var (gensym "ALIEN")))
131 `(with-alien ((,alien-var
(array (unsigned 8) ,(eval size
))))
132 (let ((,size-var
,(eval size
))
133 (,var
(alien-sap ,alien-var
)))
134 (declare (ignorable ,size-var
))
136 `(let* ((,size-var
,size
)
137 (,var
(%foreign-alloc
,size-var
)))
140 (foreign-free ,var
)))))
144 ;;; Functions and macros for allocating foreign memory on the stack
145 ;;; and on the heap. The main CFFI package defines macros that wrap
146 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
147 ;;; when the memory has dynamic extent.
149 (defun %foreign-alloc
(size)
150 "Allocate SIZE bytes on the heap and return a pointer."
151 (declare (type (unsigned-byte 32) size
))
155 (function system-area-pointer unsigned
))
158 (defun foreign-free (ptr)
159 "Free a PTR allocated by FOREIGN-ALLOC."
160 (declare (type system-area-pointer ptr
))
164 (function (values) system-area-pointer
))
167 ;;;# Shareable Vectors
169 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
170 ;;; should be defined to perform a copy-in/copy-out if the Lisp
171 ;;; implementation can't do this.
173 (defun make-shareable-byte-vector (size)
174 "Create a Lisp vector of SIZE bytes that can passed to
175 WITH-POINTER-TO-VECTOR-DATA."
176 (make-array size
:element-type
'(unsigned-byte 8)))
178 (defmacro with-pointer-to-vector-data
((ptr-var vector
) &body body
)
179 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
181 (let ((,ptr-var
(sys:vector-sap
,vector
)))
186 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
187 ;;; macros that optimize the case where the type keyword is constant
189 (defmacro define-mem-accessors
(&body pairs
)
191 (defun %mem-ref
(ptr type
&optional
(offset 0))
193 ,@(loop for
(keyword fn
) in pairs
194 collect
`(,keyword
(,fn ptr offset
)))))
195 (defun %mem-set
(value ptr type
&optional
(offset 0))
197 ,@(loop for
(keyword fn
) in pairs
198 collect
`(,keyword
(setf (,fn ptr offset
) value
)))))
199 (define-compiler-macro %mem-ref
200 (&whole form ptr type
&optional
(offset 0))
203 ,@(loop for
(keyword fn
) in pairs
204 collect
`(,keyword
`(,',fn
,ptr
,offset
))))
206 (define-compiler-macro %mem-set
207 (&whole form value ptr type
&optional
(offset 0))
211 ,@(loop for
(keyword fn
) in pairs
212 collect
`(,keyword
`(setf (,',fn
,ptr
,offset
)
216 (define-mem-accessors
217 (:char sys
:signed-sap-ref-8
)
218 (:unsigned-char sys
:sap-ref-8
)
219 (:short sys
:signed-sap-ref-16
)
220 (:unsigned-short sys
:sap-ref-16
)
221 (:int sys
:signed-sap-ref-32
)
222 (:unsigned-int sys
:sap-ref-32
)
223 (:long sys
:signed-sap-ref-32
)
224 (:unsigned-long sys
:sap-ref-32
)
225 (:long-long sys
:signed-sap-ref-64
)
226 (:unsigned-long-long sys
:sap-ref-64
)
227 (:float sys
:sap-ref-single
)
228 (:double sys
:sap-ref-double
)
229 (:pointer sys
:sap-ref-sap
))
231 ;;;# Calling Foreign Functions
233 (defun convert-foreign-type (type-keyword)
234 "Convert a CFFI type keyword to an ALIEN type."
237 (:unsigned-char
'unsigned-char
)
239 (:unsigned-short
'unsigned-short
)
241 (:unsigned-int
'unsigned-int
)
243 (:unsigned-long
'unsigned-long
)
244 (:long-long
'(signed 64))
245 (:unsigned-long-long
'(unsigned 64))
246 (:float
'single-float
)
247 (:double
'double-float
)
248 (:pointer
'system-area-pointer
)
251 (defun %foreign-type-size
(type-keyword)
252 "Return the size in bytes of a foreign type."
253 (/ (alien-internals:alien-type-bits
254 (alien-internals:parse-alien-type
255 (convert-foreign-type type-keyword
))) 8))
257 (defun %foreign-type-alignment
(type-keyword)
258 "Return the alignment in bytes of a foreign type."
259 (/ (alien-internals:alien-type-alignment
260 (alien-internals:parse-alien-type
261 (convert-foreign-type type-keyword
))) 8))
263 (defun foreign-funcall-type-and-args (args)
264 "Return an ALIEN function type for ARGS."
265 (let ((return-type nil
))
266 (loop for
(type arg
) on args by
#'cddr
267 if arg collect
(convert-foreign-type type
) into types
268 and collect arg into fargs
269 else do
(setf return-type
(convert-foreign-type type
))
270 finally
(return (values types fargs return-type
)))))
272 (defmacro %%foreign-funcall
(name types fargs rettype
)
273 "Internal guts of %FOREIGN-FUNCALL."
275 (extern-alien ,name
(function ,rettype
,@types
))
278 (defmacro %foreign-funcall
(name args
&key library calling-convention
)
279 "Perform a foreign function call, document it more later."
280 (declare (ignore library calling-convention
))
281 (multiple-value-bind (types fargs rettype
)
282 (foreign-funcall-type-and-args args
)
283 `(%%foreign-funcall
,name
,types
,fargs
,rettype
)))
285 (defmacro %foreign-funcall-pointer
(ptr args
&key calling-convention
)
286 "Funcall a pointer to a foreign function."
287 (declare (ignore calling-convention
))
288 (multiple-value-bind (types fargs rettype
)
289 (foreign-funcall-type-and-args args
)
290 (with-unique-names (function)
291 `(with-alien ((,function
(* (function ,rettype
,@types
)) ,ptr
))
292 (alien-funcall ,function
,@fargs
)))))
296 (defvar *callbacks
* (make-hash-table))
298 ;;; Create a package to contain the symbols for callback functions. We
299 ;;; want to redefine callbacks with the same symbol so the internal data
300 ;;; structures are reused.
301 (defpackage #:cffi-callbacks
304 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
305 ;;; callback for NAME.
306 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
307 (defun intern-callback (name)
308 (intern (format nil
"~A::~A" (package-name (symbol-package name
))
312 (defmacro %defcallback
(name rettype arg-names arg-types body
313 &key calling-convention
)
314 (declare (ignore calling-convention
))
315 (let ((cb-name (intern-callback name
)))
317 (def-callback ,cb-name
318 (,(convert-foreign-type rettype
)
319 ,@(mapcar (lambda (sym type
)
320 (list sym
(convert-foreign-type type
)))
321 arg-names arg-types
))
323 (setf (gethash ',name
*callbacks
*) (callback ,cb-name
)))))
325 (defun %callback
(name)
326 (multiple-value-bind (pointer winp
)
327 (gethash name
*callbacks
*)
329 (error "Undefined callback: ~S" name
))
332 ;;; CMUCL makes new callback trampolines when it reloads, so we need
333 ;;; to update CFFI's copies.
334 (defun reset-callbacks ()
335 (loop for k being the hash-keys of
*callbacks
*
336 do
(setf (gethash k
*callbacks
*)
337 (alien::symbol-trampoline
(intern-callback k
)))))
339 ;; Needs to be after cmucl's restore-callbacks, so put at the end...
340 (unless (member 'reset-callbacks ext
:*after-save-initializations
*)
341 (setf ext
:*after-save-initializations
*
342 (append ext
:*after-save-initializations
* (list 'reset-callbacks
))))
344 ;;;# Loading and Closing Foreign Libraries
346 ;;; Work-around for compiling ffi code without loading the
347 ;;; respective library at compile-time.
348 (setf c
::top-level-lambda-max
0)
350 (defun %load-foreign-library
(name path
)
351 "Load the foreign library NAME."
352 ;; On some platforms SYS::LOAD-OBJECT-FILE signals an error when
353 ;; loading fails, but on others (Linux for instance) it returns
354 ;; two values: NIL and an error string.
355 (declare (ignore name
))
356 (multiple-value-bind (ret message
)
357 (sys::load-object-file path
)
360 ((stringp message
) (error "~A" message
))
361 ;; The library was already loaded.
362 ((null ret
) (cdr (rassoc path sys
::*global-table
* :test
#'string
=)))
363 ;; The library has been loaded, but since SYS::LOAD-OBJECT-FILE
364 ;; returns an alist of *all* loaded libraries along with their addresses
365 ;; we return only the handler associated with the library just loaded.
366 (t (cdr (rassoc path ret
:test
#'string
=))))))
368 ;;; XXX: doesn't work on Darwin; does not check for errors. I suppose we'd
369 ;;; want something like SBCL's dlclose-or-lose in foreign-load.lisp:66
370 (defun %close-foreign-library
(handler)
371 "Closes a foreign library."
372 (let ((lib (rassoc (ext:unix-namestring handler
) sys
::*global-table
*
374 (sys::dlclose
(car lib
))
375 (setf (car lib
) (sys:int-sap
0))))
377 (defun native-namestring (pathname)
378 (ext:unix-namestring pathname
))
382 (defun %foreign-symbol-pointer
(name library
)
383 "Returns a pointer to a foreign symbol NAME."
384 (declare (ignore library
))
385 (let ((address (sys:alternate-get-global-address
386 (vm:extern-alien-name name
))))
389 (sys:int-sap address
))))