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