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