external/cffi.darcs/src/cffi-cmucl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-cmucl.lisp --- CFFI-SYS implementation for CMU CL.
   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 #:alien #:c-call #: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           #+unix    cffi-features:unix
  69           #+x86     cffi-features:x86
  70           #+(and ppc (not ppc64)) cffi-features:ppc32
  71           ;; Misfeatures
  72           cffi-features:flat-namespace
  73           )))
  74
  75 ;;; Symbol case.
  76
  77 (defun canonicalize-symbol-name-case (name)
  78   (declare (string name))
  79   (string-upcase name))
  80
  81 ;;;# Basic Pointer Operations
  82
  83 (deftype foreign-pointer ()
  84   'sys:system-area-pointer)
  85
  86 (declaim (inline pointerp))
  87 (defun pointerp (ptr)
  88   "Return true if PTR is a foreign pointer."
  89   (sys:system-area-pointer-p ptr))
  90
  91 (declaim (inline pointer-eq))
  92 (defun pointer-eq (ptr1 ptr2)
  93   "Return true if PTR1 and PTR2 point to the same address."
  94   (sys:sap= ptr1 ptr2))
  95
  96 (declaim (inline null-pointer))
  97 (defun null-pointer ()
  98   "Construct and return a null pointer."
  99   (sys:int-sap 0))
 100
 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)))
 105
 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))
 110
 111 (declaim (inline make-pointer))
 112 (defun make-pointer (address)
 113   "Return a pointer pointing to ADDRESS."
 114   (sys:int-sap address))
 115
 116 (declaim (inline pointer-address))
 117 (defun pointer-address (ptr)
 118   "Return the address pointed to by PTR."
 119   (sys:sap-int ptr))
 120
 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."
 126   (unless size-var
 127     (setf size-var (gensym "SIZE")))
 128   ;; If the size is constant we can stack-allocate.
 129   (if (constantp size)
 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))
 135              ,@body)))
 136       `(let* ((,size-var ,size)
 137               (,var (%foreign-alloc ,size-var)))
 138          (unwind-protect
 139               (progn ,@body)
 140            (foreign-free ,var)))))
 141
 142 ;;;# Allocation
 143 ;;;
 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.
 148
 149 (defun %foreign-alloc (size)
 150   "Allocate SIZE bytes on the heap and return a pointer."
 151   (declare (type (unsigned-byte 32) size))
 152   (alien-funcall
 153    (extern-alien
 154     "malloc"
 155     (function system-area-pointer unsigned))
 156    size))
 157
 158 (defun foreign-free (ptr)
 159   "Free a PTR allocated by FOREIGN-ALLOC."
 160   (declare (type system-area-pointer ptr))
 161   (alien-funcall
 162    (extern-alien
 163     "free"
 164     (function (values) system-area-pointer))
 165    ptr))
 166
 167 ;;;# Shareable Vectors
 168 ;;;
 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.
 172
 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)))
 177
 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   `(sys:without-gcing
 181      (let ((,ptr-var (sys:vector-sap ,vector)))
 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 (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))
 230
 231 ;;;# Calling Foreign Functions
 232
 233 (defun convert-foreign-type (type-keyword)
 234   "Convert a CFFI type keyword to an ALIEN type."
 235   (ecase type-keyword
 236     (:char               'char)
 237     (:unsigned-char      'unsigned-char)
 238     (:short              'short)
 239     (:unsigned-short     'unsigned-short)
 240     (:int                'int)
 241     (:unsigned-int       'unsigned-int)
 242     (:long               'long)
 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)
 249     (:void               'void)))
 250
 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))
 256
 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))
 262
 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)))))
 271
 272 (defmacro %%foreign-funcall (name types fargs rettype)
 273   "Internal guts of %FOREIGN-FUNCALL."
 274   `(alien-funcall
 275     (extern-alien ,name (function ,rettype ,@types))
 276     ,@fargs))
 277
 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)))
 284
 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)))))
 293
 294 ;;;# Callbacks
 295
 296 (defvar *callbacks* (make-hash-table))
 297
 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
 302   (:use))
 303
 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))
 309                     (symbol-name name))
 310             '#:cffi-callbacks)))
 311
 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)))
 316     `(progn
 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))
 322          ,body)
 323        (setf (gethash ',name *callbacks*) (callback ,cb-name)))))
 324
 325 (defun %callback (name)
 326   (multiple-value-bind (pointer winp)
 327       (gethash name *callbacks*)
 328     (unless winp
 329       (error "Undefined callback: ~S" name))
 330     pointer))
 331
 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)))))
 338
 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))))
 343
 344 ;;;# Loading and Closing Foreign Libraries
 345
 346 ;;; Work-around for compiling ffi code without loading the
 347 ;;; respective library at compile-time.
 348 (setf c::top-level-lambda-max 0)
 349
 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)
 358     (cond
 359       ;; Loading failed.
 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=))))))
 367
 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*
 373                      :test #'string=)))
 374     (sys::dlclose (car lib))
 375     (setf (car lib) (sys:int-sap 0))))
 376
 377 (defun native-namestring (pathname)
 378   (ext:unix-namestring pathname))
 379
 380 ;;;# Foreign Globals
 381
 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))))
 387     (if (zerop address)
 388         nil
 389         (sys:int-sap address))))