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 #:alexandria)
  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         '(cffi-features:flat-namespace)))
  67
  68 ;;;# Symbol Case
  69
  70 (defun canonicalize-symbol-name-case (name)
  71   (declare (string name))
  72   (string-upcase name))
  73
  74 ;;;# Basic Pointer Operations
  75
  76 (deftype foreign-pointer ()
  77   'sys:system-area-pointer)
  78
  79 (declaim (inline pointerp))
  80 (defun pointerp (ptr)
  81   "Return true if PTR is a foreign pointer."
  82   (sys:system-area-pointer-p ptr))
  83
  84 (declaim (inline pointer-eq))
  85 (defun pointer-eq (ptr1 ptr2)
  86   "Return true if PTR1 and PTR2 point to the same address."
  87   (sys:sap= ptr1 ptr2))
  88
  89 (declaim (inline null-pointer))
  90 (defun null-pointer ()
  91   "Construct and return a null pointer."
  92   (sys:int-sap 0))
  93
  94 (declaim (inline null-pointer-p))
  95 (defun null-pointer-p (ptr)
  96   "Return true if PTR is a null pointer."
  97   (zerop (sys:sap-int ptr)))
  98
  99 (declaim (inline inc-pointer))
 100 (defun inc-pointer (ptr offset)
 101   "Return a pointer pointing OFFSET bytes past PTR."
 102   (sys:sap+ ptr offset))
 103
 104 (declaim (inline make-pointer))
 105 (defun make-pointer (address)
 106   "Return a pointer pointing to ADDRESS."
 107   (sys:int-sap address))
 108
 109 (declaim (inline pointer-address))
 110 (defun pointer-address (ptr)
 111   "Return the address pointed to by PTR."
 112   (sys:sap-int ptr))
 113
 114 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 115   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
 116 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 117 may be stack-allocated if supported by the implementation.  If
 118 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 119   (unless size-var
 120     (setf size-var (gensym "SIZE")))
 121   ;; If the size is constant we can stack-allocate.
 122   (if (constantp size)
 123       (let ((alien-var (gensym "ALIEN")))
 124         `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
 125            (let ((,size-var ,(eval size))
 126                  (,var (alien-sap ,alien-var)))
 127              (declare (ignorable ,size-var))
 128              ,@body)))
 129       `(let* ((,size-var ,size)
 130               (,var (%foreign-alloc ,size-var)))
 131          (unwind-protect
 132               (progn ,@body)
 133            (foreign-free ,var)))))
 134
 135 ;;;# Allocation
 136 ;;;
 137 ;;; Functions and macros for allocating foreign memory on the stack
 138 ;;; and on the heap.  The main CFFI package defines macros that wrap
 139 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
 140 ;;; when the memory has dynamic extent.
 141
 142 (defun %foreign-alloc (size)
 143   "Allocate SIZE bytes on the heap and return a pointer."
 144   (declare (type (unsigned-byte 32) size))
 145   (alien-funcall
 146    (extern-alien
 147     "malloc"
 148     (function system-area-pointer unsigned))
 149    size))
 150
 151 (defun foreign-free (ptr)
 152   "Free a PTR allocated by FOREIGN-ALLOC."
 153   (declare (type system-area-pointer ptr))
 154   (alien-funcall
 155    (extern-alien
 156     "free"
 157     (function (values) system-area-pointer))
 158    ptr))
 159
 160 ;;;# Shareable Vectors
 161 ;;;
 162 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 163 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 164 ;;; implementation can't do this.
 165
 166 (defun make-shareable-byte-vector (size)
 167   "Create a Lisp vector of SIZE bytes that can passed to
 168 WITH-POINTER-TO-VECTOR-DATA."
 169   (make-array size :element-type '(unsigned-byte 8)))
 170
 171 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 172   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 173   `(sys:without-gcing
 174      (let ((,ptr-var (sys:vector-sap ,vector)))
 175        ,@body)))
 176
 177 ;;;# Dereferencing
 178
 179 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
 180 ;;; macros that optimize the case where the type keyword is constant
 181 ;;; at compile-time.
 182 (defmacro define-mem-accessors (&body pairs)
 183   `(progn
 184     (defun %mem-ref (ptr type &optional (offset 0))
 185       (ecase type
 186         ,@(loop for (keyword fn) in pairs
 187                 collect `(,keyword (,fn ptr offset)))))
 188     (defun %mem-set (value ptr type &optional (offset 0))
 189       (ecase type
 190         ,@(loop for (keyword fn) in pairs
 191                 collect `(,keyword (setf (,fn ptr offset) value)))))
 192     (define-compiler-macro %mem-ref
 193         (&whole form ptr type &optional (offset 0))
 194       (if (constantp type)
 195           (ecase (eval type)
 196             ,@(loop for (keyword fn) in pairs
 197                     collect `(,keyword `(,',fn ,ptr ,offset))))
 198           form))
 199     (define-compiler-macro %mem-set
 200         (&whole form value ptr type &optional (offset 0))
 201       (if (constantp type)
 202           (once-only (value)
 203             (ecase (eval type)
 204               ,@(loop for (keyword fn) in pairs
 205                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
 206                                                 ,value)))))
 207           form))))
 208
 209 (define-mem-accessors
 210   (:char sys:signed-sap-ref-8)
 211   (:unsigned-char sys:sap-ref-8)
 212   (:short sys:signed-sap-ref-16)
 213   (:unsigned-short sys:sap-ref-16)
 214   (:int sys:signed-sap-ref-32)
 215   (:unsigned-int sys:sap-ref-32)
 216   (:long sys:signed-sap-ref-32)
 217   (:unsigned-long sys:sap-ref-32)
 218   (:long-long sys:signed-sap-ref-64)
 219   (:unsigned-long-long sys:sap-ref-64)
 220   (:float sys:sap-ref-single)
 221   (:double sys:sap-ref-double)
 222   (:pointer sys:sap-ref-sap))
 223
 224 ;;;# Calling Foreign Functions
 225
 226 (defun convert-foreign-type (type-keyword)
 227   "Convert a CFFI type keyword to an ALIEN type."
 228   (ecase type-keyword
 229     (:char               'char)
 230     (:unsigned-char      'unsigned-char)
 231     (:short              'short)
 232     (:unsigned-short     'unsigned-short)
 233     (:int                'int)
 234     (:unsigned-int       'unsigned-int)
 235     (:long               'long)
 236     (:unsigned-long      'unsigned-long)
 237     (:long-long          '(signed 64))
 238     (:unsigned-long-long '(unsigned 64))
 239     (:float              'single-float)
 240     (:double             'double-float)
 241     (:pointer            'system-area-pointer)
 242     (:void               'void)))
 243
 244 (defun %foreign-type-size (type-keyword)
 245   "Return the size in bytes of a foreign type."
 246   (/ (alien-internals:alien-type-bits
 247       (alien-internals:parse-alien-type
 248        (convert-foreign-type type-keyword))) 8))
 249
 250 (defun %foreign-type-alignment (type-keyword)
 251   "Return the alignment in bytes of a foreign type."
 252   (/ (alien-internals:alien-type-alignment
 253       (alien-internals:parse-alien-type
 254        (convert-foreign-type type-keyword))) 8))
 255
 256 (defun foreign-funcall-type-and-args (args)
 257   "Return an ALIEN function type for ARGS."
 258   (let ((return-type nil))
 259     (loop for (type arg) on args by #'cddr
 260           if arg collect (convert-foreign-type type) into types
 261           and collect arg into fargs
 262           else do (setf return-type (convert-foreign-type type))
 263           finally (return (values types fargs return-type)))))
 264
 265 (defmacro %%foreign-funcall (name types fargs rettype)
 266   "Internal guts of %FOREIGN-FUNCALL."
 267   `(alien-funcall
 268     (extern-alien ,name (function ,rettype ,@types))
 269     ,@fargs))
 270
 271 (defmacro %foreign-funcall (name args &key library calling-convention)
 272   "Perform a foreign function call, document it more later."
 273   (declare (ignore library calling-convention))
 274   (multiple-value-bind (types fargs rettype)
 275       (foreign-funcall-type-and-args args)
 276     `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
 277
 278 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
 279   "Funcall a pointer to a foreign function."
 280   (declare (ignore calling-convention))
 281   (multiple-value-bind (types fargs rettype)
 282       (foreign-funcall-type-and-args args)
 283     (with-unique-names (function)
 284       `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
 285          (alien-funcall ,function ,@fargs)))))
 286
 287 ;;;# Callbacks
 288
 289 (defvar *callbacks* (make-hash-table))
 290
 291 ;;; Create a package to contain the symbols for callback functions.  We
 292 ;;; want to redefine callbacks with the same symbol so the internal data
 293 ;;; structures are reused.
 294 (defpackage #:cffi-callbacks
 295   (:use))
 296
 297 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
 298 ;;; callback for NAME.
 299 (eval-when (:compile-toplevel :load-toplevel :execute)
 300   (defun intern-callback (name)
 301     (intern (format nil "~A::~A" (package-name (symbol-package name))
 302                     (symbol-name name))
 303             '#:cffi-callbacks)))
 304
 305 (defmacro %defcallback (name rettype arg-names arg-types body
 306                         &key calling-convention)
 307   (declare (ignore calling-convention))
 308   (let ((cb-name (intern-callback name)))
 309     `(progn
 310        (def-callback ,cb-name
 311            (,(convert-foreign-type rettype)
 312              ,@(mapcar (lambda (sym type)
 313                          (list sym (convert-foreign-type type)))
 314                        arg-names arg-types))
 315          ,body)
 316        (setf (gethash ',name *callbacks*) (callback ,cb-name)))))
 317
 318 (defun %callback (name)
 319   (multiple-value-bind (pointer winp)
 320       (gethash name *callbacks*)
 321     (unless winp
 322       (error "Undefined callback: ~S" name))
 323     pointer))
 324
 325 ;;; CMUCL makes new callback trampolines when it reloads, so we need
 326 ;;; to update CFFI's copies.
 327 (defun reset-callbacks ()
 328   (loop for k being the hash-keys of *callbacks*
 329         do (setf (gethash k *callbacks*)
 330                  (alien::symbol-trampoline (intern-callback k)))))
 331
 332 ;; Needs to be after cmucl's restore-callbacks, so put at the end...
 333 (unless (member 'reset-callbacks ext:*after-save-initializations*)
 334   (setf ext:*after-save-initializations*
 335         (append ext:*after-save-initializations* (list 'reset-callbacks))))
 336
 337 ;;;# Loading and Closing Foreign Libraries
 338
 339 ;;; Work-around for compiling ffi code without loading the
 340 ;;; respective library at compile-time.
 341 (setf c::top-level-lambda-max 0)
 342
 343 (defun %load-foreign-library (name path)
 344   "Load the foreign library NAME."
 345   ;; On some platforms SYS::LOAD-OBJECT-FILE signals an error when
 346   ;; loading fails, but on others (Linux for instance) it returns
 347   ;; two values: NIL and an error string.
 348   (declare (ignore name))
 349   (multiple-value-bind (ret message)
 350       (sys::load-object-file path)
 351     (cond
 352       ;; Loading failed.
 353       ((stringp message) (error "~A" message))
 354       ;; The library was already loaded.
 355       ((null ret) (cdr (rassoc path sys::*global-table* :test #'string=)))
 356       ;; The library has been loaded, but since SYS::LOAD-OBJECT-FILE
 357       ;; returns an alist of *all* loaded libraries along with their addresses
 358       ;; we return only the handler associated with the library just loaded.
 359       (t (cdr (rassoc path ret :test #'string=))))))
 360
 361 ;;; XXX: doesn't work on Darwin; does not check for errors. I suppose we'd
 362 ;;; want something like SBCL's dlclose-or-lose in foreign-load.lisp:66
 363 (defun %close-foreign-library (handler)
 364   "Closes a foreign library."
 365   (let ((lib (rassoc (ext:unix-namestring handler) sys::*global-table*
 366                      :test #'string=)))
 367     (sys::dlclose (car lib))
 368     (setf (car lib) (sys:int-sap 0))))
 369
 370 (defun native-namestring (pathname)
 371   ;; UNIX-NAMESTRING seems to be buggy?
 372   ;; (ext:unix-namestring #p"/tmp/foo bar baz/bar") => NIL
 373   #-(and) (ext:unix-namestring pathname)
 374   (namestring pathname))
 375
 376 ;;;# Foreign Globals
 377
 378 (defun %foreign-symbol-pointer (name library)
 379   "Returns a pointer to a foreign symbol NAME."
 380   (declare (ignore library))
 381   (let ((address (sys:alternate-get-global-address
 382                   (vm:extern-alien-name name))))
 383     (if (zerop address)
 384         nil
 385         (sys:int-sap address))))