1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
5 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira(@)common-lisp.net>
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
#: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
57 #:defcfun-helper-forms
61 (in-package #:cffi-sys
)
65 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
66 (mapc (lambda (feature) (pushnew feature
*features
*))
67 '(;; Backend mis-features.
68 cffi-features
:no-long-long
69 cffi-features
:flat-namespace
71 #+macosx cffi-features
:darwin
72 #+unix cffi-features
:unix
73 #+mswindows cffi-features
:windows
74 #+powerpc cffi-features
:ppc32
75 #+x86 cffi-features
:x86
76 #+x86-64 cffi-features
:x86-64
81 (defun canonicalize-symbol-name-case (name)
82 (declare (string name
))
83 (if (eq excl
:*current-case-mode
* :case-sensitive-lower
)
84 (string-downcase name
)
85 (string-upcase name
)))
87 ;;;# Basic Pointer Operations
89 (deftype foreign-pointer
()
93 "Return true if PTR is a foreign pointer."
94 (ff:foreign-address-p ptr
))
96 (defun pointer-eq (ptr1 ptr2
)
97 "Return true if PTR1 and PTR2 point to the same address."
100 (defun null-pointer ()
101 "Return a null pointer."
104 (defun null-pointer-p (ptr)
105 "Return true if PTR is a null pointer."
108 (defun inc-pointer (ptr offset
)
109 "Return a pointer pointing OFFSET bytes past PTR."
112 (defun make-pointer (address)
113 "Return a pointer pointing to ADDRESS."
114 (check-type address ff
:foreign-address
)
117 (defun pointer-address (ptr)
118 "Return the address pointed to by PTR."
119 (check-type ptr ff
:foreign-address
)
124 ;;; Functions and macros for allocating foreign memory on the stack
125 ;;; and on the heap. The main CFFI package defines macros that wrap
126 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
127 ;;; when the memory has dynamic extent.
129 (defun %foreign-alloc
(size)
130 "Allocate SIZE bytes on the heap and return a pointer."
131 (ff:allocate-fobject
:char
:c size
))
133 (defun foreign-free (ptr)
134 "Free a PTR allocated by FOREIGN-ALLOC."
135 (ff:free-fobject ptr
))
137 (defmacro with-foreign-pointer
((var size
&optional size-var
) &body body
)
138 "Bind VAR to SIZE bytes of foreign memory during BODY. The
139 pointer in VAR is invalid beyond the dynamic extent of BODY, and
140 may be stack-allocated if supported by the implementation. If
141 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
143 (setf size-var
(gensym "SIZE")))
145 (cond ((and (constantp size
) (<= (eval size
) ff
:*max-stack-fobject-bytes
*))
146 ;; stack allocation pattern
147 `(let ((,size-var
,size
))
148 (declare (ignorable ,size-var
))
149 (ff:with-stack-fobject
(,var
'(:array
:char
,size
))
150 (let ((,var
(ff:fslot-address
,var
)))
151 ;; (excl::stack-allocated-p var) => T
154 ;; amalloc + free pattern
155 `(let ((,size-var
,size
))
156 (declare (ignorable ,size-var
))
157 (ff:with-stack-fobject
(,var
:char
:allocation
:c
:size
,size-var
)
160 (ff:free-fobject
,var
))))))
162 `(let ((,size-var
,size
))
163 (declare (ignorable ,size-var
))
164 (ff:with-stack-fobject
(,var
:char
:c
,size-var
)
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 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."
180 ; `(sb-sys:without-gcing
181 ; (let ((,ptr-var (sb-sys:vector-sap ,vector)))
186 (defun convert-foreign-type (type-keyword &optional
(context :normal
))
187 "Convert a CFFI type keyword to an Allegro type."
190 (:unsigned-char
:unsigned-char
)
192 (:unsigned-short
:unsigned-short
)
194 (:unsigned-int
:unsigned-int
)
196 (:unsigned-long
:unsigned-long
)
199 (:pointer
(ecase context
201 (:funcall
:foreign-address
)))
204 (defun %mem-ref
(ptr type
&optional
(offset 0))
205 "Dereference an object of TYPE at OFFSET bytes from PTR."
206 (unless (zerop offset
)
207 (setf ptr
(inc-pointer ptr offset
)))
208 (ff:fslot-value-typed
(convert-foreign-type type
) :c ptr
))
210 ;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the
211 ;;; CFFI type is constant. Allegro does its own transformation on the
212 ;;; call that results in efficient code.
213 (define-compiler-macro %mem-ref
(&whole form ptr type
&optional
(off 0))
215 (let ((ptr-form (if (eql off
0) ptr
`(+ ,ptr
,off
))))
216 `(ff:fslot-value-typed
',(convert-foreign-type (eval type
))
220 (defun %mem-set
(value ptr type
&optional
(offset 0))
221 "Set the object of TYPE at OFFSET bytes from PTR."
222 (unless (zerop offset
)
223 (setf ptr
(inc-pointer ptr offset
)))
224 (setf (ff:fslot-value-typed
(convert-foreign-type type
) :c ptr
) value
))
226 ;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED)
227 ;;; when the CFFI type is constant. Allegro does its own
228 ;;; transformation on the call that results in efficient code.
229 (define-compiler-macro %mem-set
(&whole form val ptr type
&optional
(off 0))
232 (let ((ptr-form (if (eql off
0) ptr
`(+ ,ptr
,off
))))
233 `(setf (ff:fslot-value-typed
',(convert-foreign-type (eval type
))
234 :c
,ptr-form
) ,val
)))
237 ;;;# Calling Foreign Functions
239 (defun %foreign-type-size
(type-keyword)
240 "Return the size in bytes of a foreign type."
241 (ff:sizeof-fobject
(convert-foreign-type type-keyword
)))
243 (defun %foreign-type-alignment
(type-keyword)
244 "Returns the alignment in bytes of a foreign type."
245 #+(and powerpc macosx32
)
246 (when (eq type-keyword
:double
)
247 (return-from %foreign-type-alignment
8))
248 ;; No override necessary for the remaining types....
249 (ff::sized-ftype-prim-align
250 (ff::iforeign-type-sftype
252 (convert-foreign-type type-keyword
)))))
254 (defun foreign-funcall-type-and-args (args)
255 "Returns a list of types, list of args and return type."
256 (let ((return-type :void
))
257 (loop for
(type arg
) on args by
#'cddr
258 if arg collect
(convert-foreign-type type
:funcall
) into types
259 and collect arg into fargs
260 else do
(setf return-type
(convert-foreign-type type
:funcall
))
261 finally
(return (values types fargs return-type
)))))
263 (defun convert-to-lisp-type (type)
264 (if (equal '(* :void
) type
)
268 (:unsigned-char
'integer
) ;'unsigned-byte)
274 :unsigned-long
) 'integer
)
275 (:float
'single-float
)
276 (:double
'double-float
)
277 (:foreign-address
:foreign-address
)
280 (defun foreign-allegro-type (type)
281 (if (eq type
:foreign-address
)
285 (defun allegro-type-pair (type)
286 (list (foreign-allegro-type type
)
287 (convert-to-lisp-type type
)))
290 (defun note-named-foreign-function (symbol name types rettype
)
291 "Give Allegro's compiler a hint to perform a direct call."
292 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
293 (setf (get ',symbol
'system
::direct-ff-call
)
294 (list '(,name
:language
:c
)
297 ;; return type '(:c-type lisp-type)
298 ',(allegro-type-pair (convert-foreign-type rettype
:funcall
))
299 ;; arg types '({(:c-type lisp-type)}*)
300 '(,@(loop for type in types
301 collect
(allegro-type-pair
302 (convert-foreign-type type
:funcall
))))
304 ff
::ep-flag-never-release
))))
306 (defmacro %foreign-funcall
(name args
&key calling-convention library
)
307 (declare (ignore calling-convention library
))
308 (multiple-value-bind (types fargs rettype
)
309 (foreign-funcall-type-and-args args
)
311 (load-time-value (excl::determine-foreign-address
312 '(,name
:language
:c
)
313 ff
::ep-flag-never-release
316 ;; arg types {'(:c-type lisp-type) argN}*
317 ,@(mapcan (lambda (type arg
)
318 `(',(allegro-type-pair type
) ,arg
))
320 ;; return type '(:c-type lisp-type)
321 ',(allegro-type-pair rettype
))))
323 (defun defcfun-helper-forms (name lisp-name rettype args types options
)
324 "Return 2 values for DEFCFUN. A prelude form and a caller form."
325 (declare (ignore options
))
326 (let ((ff-name (intern (format nil
"%cffi-foreign-function/~A" lisp-name
))))
328 `(ff:def-foreign-call
(,ff-name
,name
)
329 ,(mapcar (lambda (ty)
330 (let ((allegro-type (convert-foreign-type ty
)))
331 (list (gensym) allegro-type
332 (convert-to-lisp-type allegro-type
))))
334 :returning
,(allegro-type-pair
335 (convert-foreign-type rettype
:funcall
))
336 ;; Don't use call-direct when there are no arguments.
337 ,@(unless (null args
) '(:call-direct t
))
339 :strings-convert nil
)
340 `(,ff-name
,@args
))))
342 ;;; See doc/allegro-internals.txt for a clue about entry-vec.
343 (defmacro %foreign-funcall-pointer
(ptr args
&key calling-convention
)
344 (declare (ignore calling-convention
))
345 (multiple-value-bind (types fargs rettype
)
346 (foreign-funcall-type-and-args args
)
347 (with-unique-names (entry-vec)
348 `(let ((,entry-vec
(excl::make-entry-vec-boa
)))
349 (setf (aref ,entry-vec
1) ,ptr
) ; set jump address
352 ;; arg types {'(:c-type lisp-type) argN}*
353 ,@(mapcan (lambda (type arg
)
354 `(',(allegro-type-pair type
) ,arg
))
356 ;; return type '(:c-type lisp-type)
357 ',(allegro-type-pair rettype
))))))
361 ;;; The *CALLBACKS* hash table contains information about a callback
362 ;;; for the Allegro FFI. The key is the name of the CFFI callback,
363 ;;; and the value is a cons, the car containing the symbol the
364 ;;; callback was defined on in the CFFI-CALLBACKS package, the cdr
365 ;;; being an Allegro FFI pointer (a fixnum) that can be passed to C
368 ;;; These pointers must be restored when a saved Lisp image is loaded.
369 ;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to
370 ;;; re-register the callbacks during Lisp startup.
371 (defvar *callbacks
* (make-hash-table))
373 ;;; Register a callback in the *CALLBACKS* hash table.
374 (defun register-callback (cffi-name callback-name
)
375 (setf (gethash cffi-name
*callbacks
*)
376 (cons callback-name
(ff:register-foreign-callable
377 callback-name
:reuse t
))))
379 ;;; Restore the saved pointers in *CALLBACKS* when loading an image.
380 (defun restore-callbacks ()
381 (maphash (lambda (key value
)
382 (register-callback key
(car value
)))
385 ;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing
386 ;;; CFFI is restarted.
387 (eval-when (:load-toplevel
:execute
)
388 (pushnew 'restore-callbacks excl
:*restart-actions
*))
390 ;;; Create a package to contain the symbols for callback functions.
391 (defpackage #:cffi-callbacks
394 (defun intern-callback (name)
395 (intern (format nil
"~A::~A" (package-name (symbol-package name
))
399 (defun convert-cconv (cconv)
402 (:stdcall
:stdcall
)))
404 (defmacro %defcallback
(name rettype arg-names arg-types body
405 &key calling-convention
)
406 (declare (ignore rettype
))
407 (let ((cb-name (intern-callback name
)))
409 (ff:defun-foreign-callable
,cb-name
410 ,(mapcar (lambda (sym type
) (list sym
(convert-foreign-type type
)))
412 (declare (:convention
,(convert-cconv calling-convention
)))
414 (register-callback ',name
',cb-name
))))
416 ;;; Return the saved Lisp callback pointer from *CALLBACKS* for the
417 ;;; CFFI callback named NAME.
418 (defun %callback
(name)
419 (or (cdr (gethash name
*callbacks
*))
420 (error "Undefined callback: ~S" name
)))
422 ;;;# Loading and Closing Foreign Libraries
424 (defun %load-foreign-library
(name path
)
425 "Load a foreign library."
426 ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load
427 ;; the argument. However, previous versions do not and will only
428 ;; foreign load the argument if its type is a member of the
429 ;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special
430 ;; to a list containing whatever type NAME has.
431 (declare (ignore name
))
432 (let ((excl::*load-foreign-types
*
433 (list (pathname-type (parse-namestring path
)))))
436 #+(version>= 7) (load path
:foreign t
)
437 #-
(version>= 7) (load path
))
439 (error (change-class fe
'simple-error
))))
442 (defun %close-foreign-library
(name)
443 "Close the foreign library NAME."
444 (ff:unload-foreign-library name
))
446 (defun native-namestring (pathname)
447 (namestring pathname
))
451 (defun convert-external-name (name)
452 "Add an underscore to NAME if necessary for the ABI."
453 #+macosx
(concatenate 'string
"_" name
)
456 (defun %foreign-symbol-pointer
(name library
)
457 "Returns a pointer to a foreign symbol NAME."
458 (declare (ignore library
))
459 (prog1 (ff:get-entry-point
(convert-external-name name
))))