external/cffi.darcs/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 #:cffi-utils)
  32   (:export
  33    #:canonicalize-symbol-name-case
  34    #:foreign-pointer
  35    #:pointerp
  36    #:pointer-eq
  37    #:null-pointer
  38    #:null-pointer-p
  39    #:inc-pointer
  40    #:make-pointer
  41    #:pointer-address
  42    #:%foreign-alloc
  43    #:foreign-free
  44    #:with-foreign-pointer
  45    #:%foreign-funcall
  46    #:%foreign-funcall-pointer
  47    #:%foreign-type-alignment
  48    #:%foreign-type-size
  49    #:%load-foreign-library
  50    #:%close-foreign-library
  51    #:native-namestring
  52    #:%mem-ref
  53    #:%mem-set
  54    #:make-shareable-byte-vector
  55    #:with-pointer-to-vector-data
  56    #:%foreign-symbol-pointer
  57    #:%defcallback
  58    #:%callback))
  59
  60 (in-package #:cffi-sys)
  61
  62 ;;;# Features
  63
  64 (eval-when (:compile-toplevel :load-toplevel :execute)
  65   (mapc (lambda (feature) (pushnew feature *features*))
  66         '(;; OS/CPU 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
  73           ;; Misfeatures
  74           cffi-features:flat-namespace
  75           )))
  76
  77 ;;; Symbol case.
  78
  79 (declaim (inline canonicalize-symbol-name-case))
  80 (defun canonicalize-symbol-name-case (name)
  81   (declare (string name))
  82   (string-upcase name))
  83
  84 ;;;# Basic Pointer Operations
  85
  86 (deftype foreign-pointer ()
  87   'sb-sys:system-area-pointer)
  88
  89 (declaim (inline pointerp))
  90 (defun pointerp (ptr)
  91   "Return true if PTR is a foreign pointer."
  92   (sb-sys:system-area-pointer-p ptr))
  93
  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))
  99
 100 (declaim (inline null-pointer))
 101 (defun null-pointer ()
 102   "Construct and return a null pointer."
 103   (sb-sys:int-sap 0))
 104
 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)))
 110
 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))
 117
 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))
 123
 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))
 129
 130 ;;;# Allocation
 131 ;;;
 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.
 136
 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)))
 142
 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)))))
 148
 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."
 154   (unless size-var
 155     (setf size-var (gensym "SIZE")))
 156   ;; If the size is constant we can stack-allocate.
 157   (if (constantp size)
 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))
 163              ,@body)))
 164       `(let* ((,size-var ,size)
 165               (,var (%foreign-alloc ,size-var)))
 166          (unwind-protect
 167               (progn ,@body)
 168            (foreign-free ,var)))))
 169
 170 ;;;# Shareable Vectors
 171 ;;;
 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.
 175
 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)))
 182
 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)))
 190            ,@body)))))
 191
 192 ;;;# Dereferencing
 193
 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
 196 ;;; at compile-time.
 197 (defmacro define-mem-accessors (&body pairs)
 198   `(progn
 199      (defun %mem-ref (ptr type &optional (offset 0))
 200        (ecase type
 201          ,@(loop for (keyword fn) in pairs
 202                  collect `(,keyword (,fn ptr offset)))))
 203      (defun %mem-set (value ptr type &optional (offset 0))
 204        (ecase type
 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))
 209        (if (constantp type)
 210            (ecase (eval type)
 211              ,@(loop for (keyword fn) in pairs
 212                      collect `(,keyword `(,',fn ,ptr ,offset))))
 213            form))
 214      (define-compiler-macro %mem-set
 215          (&whole form value ptr type &optional (offset 0))
 216        (if (constantp type)
 217            (once-only (value)
 218              (ecase (eval type)
 219                ,@(loop for (keyword fn) in pairs
 220                        collect `(,keyword `(setf (,',fn ,ptr ,offset)
 221                                                  ,value)))))
 222            form))))
 223
 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))
 238
 239 ;;;# Calling Foreign Functions
 240
 241 (defun convert-foreign-type (type-keyword)
 242   "Convert a CFFI type keyword to an SB-ALIEN type."
 243   (ecase type-keyword
 244     (:char               'char)
 245     (:unsigned-char      'unsigned-char)
 246     (:short              'short)
 247     (:unsigned-short     'unsigned-short)
 248     (:int                'int)
 249     (:unsigned-int       'unsigned-int)
 250     (:long               'long)
 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)
 257     (:void               'void)))
 258
 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))
 264
 265 (defun %foreign-type-alignment (type-keyword)
 266   "Return the alignment in bytes of a foreign type."
 267   #+(and darwin ppc (not ppc64))
 268   (case type-keyword
 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))
 275
 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)))))
 284
 285 (defmacro %%foreign-funcall (name types fargs rettype)
 286   "Internal guts of %FOREIGN-FUNCALL."
 287   `(alien-funcall
 288     (extern-alien ,name (function ,rettype ,@types))
 289     ,@fargs))
 290
 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)))
 297
 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)))))
 306
 307 ;;;# Callbacks
 308
 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))
 314
 315 (defmacro %defcallback (name rettype arg-names arg-types body
 316                         &key calling-convention)
 317   (declare (ignore calling-convention))
 318   `(setf (gethash ',name *callbacks*)
 319          (alien-sap
 320           (sb-alien::alien-lambda ,(convert-foreign-type rettype)
 321               ,(mapcar (lambda (sym type)
 322                          (list sym (convert-foreign-type type)))
 323                        arg-names arg-types)
 324             ,body))))
 325
 326 (defun %callback (name)
 327   (or (gethash name *callbacks*)
 328       (error "Undefined callback: ~S" name)))
 329
 330 ;;;# Loading and Closing Foreign Libraries
 331
 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))
 337
 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
 343          :test #'string=)))
 344
 345 (defun native-namestring (pathname)
 346   (sb-ext:native-namestring pathname))
 347
 348 ;;;# Foreign Globals
 349
 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)))