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