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