src/cffi-sbcl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   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 ;;;
  27
  28 ;;;# Administrivia
  29
  30 (defpackage #:cffi-sys
  31   (:use #:common-lisp #:sb-alien)
  32   (:import-from #:alexandria
  33                 #:once-only #:with-unique-names #:when-let #:removef)
  34   (:export
  35    #:canonicalize-symbol-name-case
  36    #:foreign-pointer
  37    #:pointerp
  38    #:pointer-eq
  39    #:null-pointer
  40    #:null-pointer-p
  41    #:inc-pointer
  42    #:make-pointer
  43    #:pointer-address
  44    #:%foreign-alloc
  45    #:foreign-free
  46    #:with-foreign-pointer
  47    #:%foreign-funcall
  48    #:%foreign-funcall-pointer
  49    #:%foreign-type-alignment
  50    #:%foreign-type-size
  51    #:%load-foreign-library
  52    #:%close-foreign-library
  53    #:native-namestring
  54    #:%mem-ref
  55    #:%mem-set
  56    #:make-shareable-byte-vector
  57    #:with-pointer-to-vector-data
  58    #:%foreign-symbol-pointer
  59    #:%defcallback
  60    #:%callback))
  61
  62 (in-package #:cffi-sys)
  63
  64 ;;;# Misfeatures
  65
  66 (pushnew 'flat-namespace *features*)
  67
  68 ;;;# Symbol Case
  69
  70 (declaim (inline canonicalize-symbol-name-case))
  71 (defun canonicalize-symbol-name-case (name)
  72   (declare (string name))
  73   (string-upcase name))
  74
  75 ;;;# Basic Pointer Operations
  76
  77 (deftype foreign-pointer ()
  78   'sb-sys:system-area-pointer)
  79
  80 (declaim (inline pointerp))
  81 (defun pointerp (ptr)
  82   "Return true if PTR is a foreign pointer."
  83   (sb-sys:system-area-pointer-p ptr))
  84
  85 (declaim (inline pointer-eq))
  86 (defun pointer-eq (ptr1 ptr2)
  87   "Return true if PTR1 and PTR2 point to the same address."
  88   (declare (type system-area-pointer ptr1 ptr2))
  89   (sb-sys:sap= ptr1 ptr2))
  90
  91 (declaim (inline null-pointer))
  92 (defun null-pointer ()
  93   "Construct and return a null pointer."
  94   (sb-sys:int-sap 0))
  95
  96 (declaim (inline null-pointer-p))
  97 (defun null-pointer-p (ptr)
  98   "Return true if PTR is a null pointer."
  99   (declare (type system-area-pointer ptr))
 100   (zerop (sb-sys:sap-int ptr)))
 101
 102 (declaim (inline inc-pointer))
 103 (defun inc-pointer (ptr offset)
 104   "Return a pointer pointing OFFSET bytes past PTR."
 105   (declare (type system-area-pointer ptr)
 106            (type integer offset))
 107   (sb-sys:sap+ ptr offset))
 108
 109 (declaim (inline make-pointer))
 110 (defun make-pointer (address)
 111   "Return a pointer pointing to ADDRESS."
 112   ;; (declare (type (unsigned-byte 32) address))
 113   (sb-sys:int-sap address))
 114
 115 (declaim (inline pointer-address))
 116 (defun pointer-address (ptr)
 117   "Return the address pointed to by PTR."
 118   (declare (type system-area-pointer ptr))
 119   (sb-sys:sap-int ptr))
 120
 121 ;;;# Allocation
 122 ;;;
 123 ;;; Functions and macros for allocating foreign memory on the stack
 124 ;;; and on the heap.  The main CFFI package defines macros that wrap
 125 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
 126 ;;; when the memory has dynamic extent.
 127
 128 (declaim (inline %foreign-alloc))
 129 (defun %foreign-alloc (size)
 130   "Allocate SIZE bytes on the heap and return a pointer."
 131   ;; (declare (type (unsigned-byte 32) size))
 132   (alien-sap (make-alien (unsigned 8) size)))
 133
 134 (declaim (inline foreign-free))
 135 (defun foreign-free (ptr)
 136   "Free a PTR allocated by FOREIGN-ALLOC."
 137   (declare (type system-area-pointer ptr)
 138            (optimize speed))
 139   (free-alien (sap-alien ptr (* (unsigned 8)))))
 140
 141 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 142   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
 143 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 144 may be stack-allocated if supported by the implementation.  If
 145 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 146   (unless size-var
 147     (setf size-var (gensym "SIZE")))
 148   ;; If the size is constant we can stack-allocate.
 149   (if (constantp size)
 150       (let ((alien-var (gensym "ALIEN")))
 151         `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
 152            (let ((,size-var ,(eval size))
 153                  (,var (alien-sap ,alien-var)))
 154              (declare (ignorable ,size-var))
 155              ,@body)))
 156       `(let* ((,size-var ,size)
 157               (,var (%foreign-alloc ,size-var)))
 158          (unwind-protect
 159               (progn ,@body)
 160            (foreign-free ,var)))))
 161
 162 ;;;# Shareable Vectors
 163 ;;;
 164 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 165 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 166 ;;; implementation can't do this.
 167
 168 (declaim (inline make-shareable-byte-vector))
 169 (defun make-shareable-byte-vector (size)
 170   "Create a Lisp vector of SIZE bytes can passed to
 171 WITH-POINTER-TO-VECTOR-DATA."
 172   ; (declare (type sb-int:index size))
 173   (make-array size :element-type '(unsigned-byte 8)))
 174
 175 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 176   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 177   (let ((vector-var (gensym "VECTOR")))
 178     `(let ((,vector-var ,vector))
 179        (declare (type (sb-kernel:simple-unboxed-array (*)) ,vector-var))
 180        (sb-sys:with-pinned-objects (,vector-var)
 181          (let ((,ptr-var (sb-sys:vector-sap ,vector-var)))
 182            ,@body)))))
 183
 184 ;;;# Dereferencing
 185
 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
 188 ;;; at compile-time.
 189 (defmacro define-mem-accessors (&body pairs)
 190   `(progn
 191      (defun %mem-ref (ptr type &optional (offset 0))
 192        (ecase type
 193          ,@(loop for (keyword fn) in pairs
 194                  collect `(,keyword (,fn ptr offset)))))
 195      (defun %mem-set (value ptr type &optional (offset 0))
 196        (ecase type
 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))
 201        (if (constantp type)
 202            (ecase (eval type)
 203              ,@(loop for (keyword fn) in pairs
 204                      collect `(,keyword `(,',fn ,ptr ,offset))))
 205            form))
 206      (define-compiler-macro %mem-set
 207          (&whole form value ptr type &optional (offset 0))
 208        (if (constantp type)
 209            (once-only (value)
 210              (ecase (eval type)
 211                ,@(loop for (keyword fn) in pairs
 212                        collect `(,keyword `(setf (,',fn ,ptr ,offset)
 213                                                  ,value)))))
 214            form))))
 215
 216 ;;; Look up alien type information and build both define-mem-accessors form
 217 ;;; and convert-foreign-type function definition.
 218 (defmacro define-type-mapping (accessor-table alien-table)
 219   (let* ((accessible-types
 220            (remove 'void alien-table :key #'second))
 221          (size-and-signedp-forms
 222            (mapcar (lambda (name)
 223                      (list (eval `(alien-size ,(second name)))
 224                            (typep -1 `(alien ,(second name)))))
 225                    accessible-types)))
 226     `(progn
 227        (define-mem-accessors
 228          ,@(loop for (cffi-keyword alien-type fixed-accessor)
 229                    in accessible-types
 230                  and (alien-size signedp)
 231                    in size-and-signedp-forms
 232                  for (signed-ref unsigned-ref)
 233                    = (cdr (assoc alien-size accessor-table))
 234                  collect
 235                  `(,cffi-keyword
 236                    ,(or fixed-accessor
 237                         (if signedp signed-ref unsigned-ref)
 238                         (error "No accessor found for ~S"
 239                                alien-type)))))
 240        (defun convert-foreign-type (type-keyword)
 241          (ecase type-keyword
 242            ,@(loop for (cffi-keyword alien-type) in alien-table
 243                    collect `(,cffi-keyword (quote ,alien-type))))))))
 244
 245 (define-type-mapping
 246     ((8  sb-sys:signed-sap-ref-8  sb-sys:sap-ref-8)
 247      (16 sb-sys:signed-sap-ref-16 sb-sys:sap-ref-16)
 248      (32 sb-sys:signed-sap-ref-32 sb-sys:sap-ref-32)
 249      (64 sb-sys:signed-sap-ref-64 sb-sys:sap-ref-64))
 250     ((:char               char)
 251      (:unsigned-char      unsigned-char)
 252      (:short              short)
 253      (:unsigned-short     unsigned-short)
 254      (:int                int)
 255      (:unsigned-int       unsigned-int)
 256      (:long               long)
 257      (:unsigned-long      unsigned-long)
 258      (:long-long          long-long)
 259      (:unsigned-long-long unsigned-long-long)
 260      (:float              single-float
 261                           sb-sys:sap-ref-single)
 262      (:double             double-float
 263                           sb-sys:sap-ref-double)
 264      (:pointer            system-area-pointer
 265                           sb-sys:sap-ref-sap)
 266      (:void               void)))
 267
 268 ;;;# Calling Foreign Functions
 269
 270 (defun %foreign-type-size (type-keyword)
 271   "Return the size in bytes of a foreign type."
 272   (/ (sb-alien-internals:alien-type-bits
 273       (sb-alien-internals:parse-alien-type
 274        (convert-foreign-type type-keyword) nil)) 8))
 275
 276 (defun %foreign-type-alignment (type-keyword)
 277   "Return the alignment in bytes of a foreign type."
 278   #+(and darwin ppc (not ppc64))
 279   (case type-keyword
 280     ((:double :long-long :unsigned-long-long)
 281      (return-from %foreign-type-alignment 8)))
 282   ;; No override necessary for other types...
 283   (/ (sb-alien-internals:alien-type-alignment
 284       (sb-alien-internals:parse-alien-type
 285        (convert-foreign-type type-keyword) nil)) 8))
 286
 287 (defun foreign-funcall-type-and-args (args)
 288   "Return an SB-ALIEN function type for ARGS."
 289   (let ((return-type 'void))
 290     (loop for (type arg) on args by #'cddr
 291           if arg collect (convert-foreign-type type) into types
 292           and collect arg into fargs
 293           else do (setf return-type (convert-foreign-type type))
 294           finally (return (values types fargs return-type)))))
 295
 296 (defmacro %%foreign-funcall (name types fargs rettype)
 297   "Internal guts of %FOREIGN-FUNCALL."
 298   `(alien-funcall
 299     (extern-alien ,name (function ,rettype ,@types))
 300     ,@fargs))
 301
 302 (defmacro %foreign-funcall (name args &key library convention)
 303   "Perform a foreign function call, document it more later."
 304   (declare (ignore library convention))
 305   (multiple-value-bind (types fargs rettype)
 306       (foreign-funcall-type-and-args args)
 307     `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
 308
 309 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 310   "Funcall a pointer to a foreign function."
 311   (declare (ignore convention))
 312   (multiple-value-bind (types fargs rettype)
 313       (foreign-funcall-type-and-args args)
 314     (with-unique-names (function)
 315       `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
 316          (alien-funcall ,function ,@fargs)))))
 317
 318 ;;;# Callbacks
 319
 320 ;;; The *CALLBACKS* hash table contains a direct mapping of CFFI
 321 ;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA.
 322 ;;; SBCL will maintain the addresses of the callbacks across saved
 323 ;;; images, so it is safe to store the pointers directly.
 324 (defvar *callbacks* (make-hash-table))
 325
 326 (defmacro %defcallback (name rettype arg-names arg-types body
 327                         &key convention)
 328   (check-type convention (member :stdcall :cdecl))
 329   `(setf (gethash ',name *callbacks*)
 330          (alien-sap
 331           (sb-alien::alien-lambda
 332             #+alien-callback-conventions
 333             (,convention ,(convert-foreign-type rettype))
 334             #-alien-callback-conventions
 335             ,(convert-foreign-type rettype)
 336             ,(mapcar (lambda (sym type)
 337                        (list sym (convert-foreign-type type)))
 338                arg-names arg-types)
 339             ,body))))
 340
 341 (defun %callback (name)
 342   (or (gethash name *callbacks*)
 343       (error "Undefined callback: ~S" name)))
 344
 345 ;;;# Loading and Closing Foreign Libraries
 346
 347 #+darwin
 348 (defun call-within-initial-thread (fn &rest args)
 349   (let (result
 350         error
 351         (sem (sb-thread:make-semaphore)))
 352     (sb-thread:interrupt-thread
 353      ;; KLUDGE: find a better way to get the initial thread.
 354      (car (last (sb-thread:list-all-threads)))
 355      (lambda ()
 356        (multiple-value-setq (result error)
 357          (ignore-errors (apply fn args)))
 358        (sb-thread:signal-semaphore sem)))
 359     (sb-thread:wait-on-semaphore sem)
 360     (if error
 361         (signal error)
 362         result)))
 363
 364 (declaim (inline %load-foreign-library))
 365 (defun %load-foreign-library (name path)
 366   "Load a foreign library."
 367   (declare (ignore name))
 368   ;; As of MacOS X 10.6.6, loading things like CoreFoundation from a
 369   ;; thread other than the initial one results in a crash.
 370   #+darwin (call-within-initial-thread 'load-shared-object path)
 371   #-darwin (load-shared-object path))
 372
 373 ;;; SBCL 1.0.21.15 renamed SB-ALIEN::SHARED-OBJECT-FILE but introduced
 374 ;;; SB-ALIEN:UNLOAD-SHARED-OBJECT which we can use instead.
 375 (eval-when (:compile-toplevel :load-toplevel :execute)
 376   (defun unload-shared-object-present-p ()
 377     (multiple-value-bind (foundp kind)
 378         (find-symbol "UNLOAD-SHARED-OBJECT" "SB-ALIEN")
 379       (if (and foundp (eq kind :external))
 380           '(:and)
 381           '(:or)))))
 382
 383 (defun %close-foreign-library (handle)
 384   "Closes a foreign library."
 385   #+#.(cffi-sys::unload-shared-object-present-p)
 386   (sb-alien:unload-shared-object handle)
 387   #-#.(cffi-sys::unload-shared-object-present-p)
 388   (sb-thread:with-mutex (sb-alien::*shared-objects-lock*)
 389     (let ((obj (find (sb-ext:native-namestring handle)
 390                      sb-alien::*shared-objects*
 391                      :key #'sb-alien::shared-object-file
 392                      :test #'string=)))
 393       (when obj
 394         (sb-alien::dlclose-or-lose obj)
 395         (removef sb-alien::*shared-objects* obj)
 396         #+(and linkage-table (not win32))
 397         (sb-alien::update-linkage-table)))))
 398
 399 (defun native-namestring (pathname)
 400   (sb-ext:native-namestring pathname))
 401
 402 ;;;# Foreign Globals
 403
 404 (defun %foreign-symbol-pointer (name library)
 405   "Returns a pointer to a foreign symbol NAME."
 406   (declare (ignore library))
 407   (when-let (address (sb-sys:find-foreign-symbol-address name))
 408     (sb-sys:int-sap address)))