external/cffi.darcs/_darcs/pristine/src/cffi-openmcl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL.
   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 #:ccl #:cffi-utils)
  32   (:export
  33    #:canonicalize-symbol-name-case
  34    #:foreign-pointer
  35    #:pointerp  ; ccl:pointerp
  36    #:pointer-eq
  37    #:%foreign-alloc
  38    #:foreign-free
  39    #:with-foreign-pointer
  40    #:null-pointer
  41    #:null-pointer-p
  42    #:inc-pointer
  43    #:make-pointer
  44    #:pointer-address
  45    #:%mem-ref
  46    #:%mem-set
  47    #:%foreign-funcall
  48    #:%foreign-funcall-pointer
  49    #:%foreign-type-alignment
  50    #:%foreign-type-size
  51    #:%load-foreign-library
  52    #:%close-foreign-library
  53    #:native-namestring
  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-target cffi-features:darwin
  68           #+unix          cffi-features:unix
  69           #+ppc32-target  cffi-features:ppc32
  70           #+x8664-target  cffi-features:x86-64
  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 ;;;# Allocation
  82 ;;;
  83 ;;; Functions and macros for allocating foreign memory on the stack
  84 ;;; and on the heap.  The main CFFI package defines macros that wrap
  85 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
  86 ;;; usage when the memory has dynamic extent.
  87
  88 (defun %foreign-alloc (size)
  89   "Allocate SIZE bytes on the heap and return a pointer."
  90   (ccl::malloc size))
  91
  92 (defun foreign-free (ptr)
  93   "Free a PTR allocated by FOREIGN-ALLOC."
  94   ;; TODO: Should we make this a dead macptr?
  95   (ccl::free ptr))
  96
  97 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  98   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  99 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 100 may be stack-allocated if supported by the implementation.  If
 101 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 102   (unless size-var
 103     (setf size-var (gensym "SIZE")))
 104   `(let ((,size-var ,size))
 105      (%stack-block ((,var ,size-var))
 106        ,@body)))
 107
 108 ;;;# Misc. Pointer Operations
 109
 110 (deftype foreign-pointer ()
 111   'ccl:macptr)
 112
 113 (defun null-pointer ()
 114   "Construct and return a null pointer."
 115   (ccl:%null-ptr))
 116
 117 (defun null-pointer-p (ptr)
 118   "Return true if PTR is a null pointer."
 119   (ccl:%null-ptr-p ptr))
 120
 121 (defun inc-pointer (ptr offset)
 122   "Return a pointer OFFSET bytes past PTR."
 123   (ccl:%inc-ptr ptr offset))
 124
 125 (defun pointer-eq (ptr1 ptr2)
 126   "Return true if PTR1 and PTR2 point to the same address."
 127   (ccl:%ptr-eql ptr1 ptr2))
 128
 129 (defun make-pointer (address)
 130   "Return a pointer pointing to ADDRESS."
 131   (ccl:%int-to-ptr address))
 132
 133 (defun pointer-address (ptr)
 134   "Return the address pointed to by PTR."
 135   (ccl:%ptr-to-int ptr))
 136
 137 ;;;# Shareable Vectors
 138 ;;;
 139 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 140 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 141 ;;; implementation can't do this.
 142
 143 (defun make-shareable-byte-vector (size)
 144   "Create a Lisp vector of SIZE bytes that can passed to
 145 WITH-POINTER-TO-VECTOR-DATA."
 146   (make-array size :element-type '(unsigned-byte 8)))
 147
 148 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 149   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 150   `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
 151      ,@body))
 152
 153 ;;;# Dereferencing
 154
 155 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
 156 ;;; macros that optimize the case where the type keyword is constant
 157 ;;; at compile-time.
 158 (defmacro define-mem-accessors (&body pairs)
 159   `(progn
 160     (defun %mem-ref (ptr type &optional (offset 0))
 161       (ecase type
 162         ,@(loop for (keyword fn) in pairs
 163                 collect `(,keyword (,fn ptr offset)))))
 164     (defun %mem-set (value ptr type &optional (offset 0))
 165       (ecase type
 166         ,@(loop for (keyword fn) in pairs
 167                 collect `(,keyword (setf (,fn ptr offset) value)))))
 168     (define-compiler-macro %mem-ref
 169         (&whole form ptr type &optional (offset 0))
 170       (if (constantp type)
 171           (ecase (eval type)
 172             ,@(loop for (keyword fn) in pairs
 173                     collect `(,keyword `(,',fn ,ptr ,offset))))
 174           form))
 175     (define-compiler-macro %mem-set
 176         (&whole form value ptr type &optional (offset 0))
 177       (if (constantp type)
 178           (once-only (value)
 179             (ecase (eval type)
 180               ,@(loop for (keyword fn) in pairs
 181                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
 182                                                 ,value)))))
 183           form))))
 184
 185 (define-mem-accessors
 186   (:char %get-signed-byte)
 187   (:unsigned-char %get-unsigned-byte)
 188   (:short %get-signed-word)
 189   (:unsigned-short %get-unsigned-word)
 190   (:int %get-signed-long)
 191   (:unsigned-int %get-unsigned-long)
 192   #+32-bit-target (:long %get-signed-long)
 193   #+64-bit-target (:long ccl::%%get-signed-longlong)
 194   #+32-bit-target (:unsigned-long %get-unsigned-long)
 195   #+64-bit-target (:unsigned-long ccl::%%get-unsigned-longlong)
 196   (:long-long ccl::%get-signed-long-long)
 197   (:unsigned-long-long ccl::%get-unsigned-long-long)
 198   (:float %get-single-float)
 199   (:double %get-double-float)
 200   (:pointer %get-ptr))
 201
 202 ;;;# Calling Foreign Functions
 203
 204 (defun convert-foreign-type (type-keyword)
 205   "Convert a CFFI type keyword to an OpenMCL type."
 206   (ecase type-keyword
 207     (:char                :signed-byte)
 208     (:unsigned-char       :unsigned-byte)
 209     (:short               :signed-short)
 210     (:unsigned-short      :unsigned-short)
 211     (:int                 :signed-int)
 212     (:unsigned-int        :unsigned-int)
 213     (:long                :signed-long)
 214     (:unsigned-long       :unsigned-long)
 215     (:long-long           :signed-doubleword)
 216     (:unsigned-long-long  :unsigned-doubleword)
 217     (:float               :single-float)
 218     (:double              :double-float)
 219     (:pointer             :address)
 220     (:void                :void)))
 221
 222 (defun %foreign-type-size (type-keyword)
 223   "Return the size in bytes of a foreign type."
 224   (/ (ccl::foreign-type-bits
 225       (ccl::parse-foreign-type
 226        (convert-foreign-type type-keyword))) 8))
 227
 228 ;; There be dragons here.  See the following thread for details:
 229 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
 230 (defun %foreign-type-alignment (type-keyword)
 231   "Return the alignment in bytes of a foreign type."
 232   (/ (ccl::foreign-type-alignment
 233       (ccl::parse-foreign-type
 234        (convert-foreign-type type-keyword))) 8))
 235
 236 (defun convert-foreign-funcall-types (args)
 237   "Convert foreign types for a call to FOREIGN-FUNCALL."
 238   (loop for (type arg) on args by #'cddr
 239         collect (convert-foreign-type type)
 240         if arg collect arg))
 241
 242 (defun convert-external-name (name)
 243   "Add an underscore to NAME if necessary for the ABI."
 244   #+darwinppc-target (concatenate 'string "_" name)
 245   #-darwinppc-target name)
 246
 247 (defmacro %foreign-funcall (function-name args &key library calling-convention)
 248   "Perform a foreign function call, document it more later."
 249   (declare (ignore library calling-convention))
 250   `(external-call
 251     ,(convert-external-name function-name)
 252     ,@(convert-foreign-funcall-types args)))
 253
 254 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
 255   (declare (ignore calling-convention))
 256   `(ff-call ,ptr ,@(convert-foreign-funcall-types args)))
 257
 258 ;;;# Callbacks
 259
 260 ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
 261 ;;; entry points.  It is safe to store the pointers directly because
 262 ;;; OpenMCL will update the address of these pointers when a saved image
 263 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
 264 (defvar *callbacks* (make-hash-table))
 265
 266 ;;; Create a package to contain the symbols for callback functions.  We
 267 ;;; want to redefine callbacks with the same symbol so the internal data
 268 ;;; structures are reused.
 269 (defpackage #:cffi-callbacks
 270   (:use))
 271
 272 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
 273 ;;; callback for NAME.
 274 (defun intern-callback (name)
 275   (intern (format nil "~A::~A" (package-name (symbol-package name))
 276                   (symbol-name name))
 277           '#:cffi-callbacks))
 278
 279 (defmacro %defcallback (name rettype arg-names arg-types body
 280                         &key calling-convention)
 281   (declare (ignore calling-convention))
 282   (let ((cb-name (intern-callback name)))
 283     `(progn
 284        (defcallback ,cb-name
 285            (,@(mapcan (lambda (sym type)
 286                         (list (convert-foreign-type type) sym))
 287                       arg-names arg-types)
 288             ,(convert-foreign-type rettype))
 289          ,body)
 290        (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
 291
 292 (defun %callback (name)
 293   (or (gethash name *callbacks*)
 294       (error "Undefined callback: ~S" name)))
 295
 296 ;;;# Loading Foreign Libraries
 297
 298 (defun %load-foreign-library (name path)
 299   "Load the foreign library NAME."
 300   (declare (ignore name))
 301   (open-shared-library path))
 302
 303 (defun %close-foreign-library (name)
 304   "Close the foreign library NAME."
 305   (close-shared-library name)) ; :completely t ?
 306
 307 (defun native-namestring (pathname)
 308   (ccl::native-translated-namestring pathname))
 309
 310 ;;;# Foreign Globals
 311
 312 (defun %foreign-symbol-pointer (name library)
 313   "Returns a pointer to a foreign symbol NAME."
 314   (declare (ignore library))
 315   (foreign-symbol-address (convert-external-name name)))