src/cffi-mcl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-mcl.lisp --- CFFI-SYS implementation for Digitool MCL.
   4 ;;;
   5 ;;; Copyright 2010 james.anderson@setf.de
   6 ;;; Copyright 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person
   9 ;;; obtaining a copy of this software and associated documentation
  10 ;;; files (the "Software"), to deal in the Software without
  11 ;;; restriction, including without limitation the rights to use, copy,
  12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  13 ;;; of the Software, and to permit persons to whom the Software is
  14 ;;; furnished to do so, subject to the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  26 ;;; DEALINGS IN THE SOFTWARE.
  27 ;;;
  28
  29 ;;; this is a stop-gap emulation. (at least) three things are not right
  30 ;;; - integer vector arguments are copied
  31 ;;; - return values are not typed
  32 ;;; - a shared library must be packaged as a framework and statically loaded
  33 ;;;
  34 ;;; on the topic of shared libraries, see
  35 ;;; http://developer.apple.com/library/mac/#documentation/DeveloperTools/Conceptual/MachOTopics/1-Articles/loading_code.html
  36 ;;; which describes how to package a shared library as a framework.
  37 ;;; once a framework exists, load it as, eg.
  38 ;;; (ccl::add-framework-bundle "fftw.framework" :pathname "ccl:frameworks;" )
  39
  40 (in-package #:cffi-sys)
  41
  42 ;;;# Misfeatures
  43
  44 (pushnew 'flat-namespace *features*)
  45
  46 ;;;# Symbol Case
  47
  48 (defun canonicalize-symbol-name-case (name)
  49   (declare (string name))
  50   (string-upcase name))
  51
  52 ;;;# Allocation
  53 ;;;
  54 ;;; Functions and macros for allocating foreign memory on the stack
  55 ;;; and on the heap.  The main CFFI package defines macros that wrap
  56 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
  57 ;;; usage when the memory has dynamic extent.
  58
  59 (defun %foreign-alloc (size)
  60   "Allocate SIZE bytes on the heap and return a pointer."
  61   (#_newPtr size))
  62
  63 (defun foreign-free (ptr)
  64   "Free a PTR allocated by FOREIGN-ALLOC."
  65   ;; TODO: Should we make this a dead macptr?
  66   (#_disposePtr ptr))
  67
  68 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  69   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  70 pointer in VAR is invalid beyond the dynamic extent of BODY, and
  71 may be stack-allocated if supported by the implementation.  If
  72 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
  73   (unless size-var
  74     (setf size-var (gensym "SIZE")))
  75   `(let ((,size-var ,size))
  76      (ccl:%stack-block ((,var ,size-var))
  77        ,@body)))
  78
  79 ;;;# Misc. Pointer Operations
  80
  81 (deftype foreign-pointer ()
  82   'ccl:macptr)
  83
  84 (defun null-pointer ()
  85   "Construct and return a null pointer."
  86   (ccl:%null-ptr))
  87
  88 (defun null-pointer-p (ptr)
  89   "Return true if PTR is a null pointer."
  90   (ccl:%null-ptr-p ptr))
  91
  92 (defun inc-pointer (ptr offset)
  93   "Return a pointer OFFSET bytes past PTR."
  94   (ccl:%inc-ptr ptr offset))
  95
  96 (defun pointer-eq (ptr1 ptr2)
  97   "Return true if PTR1 and PTR2 point to the same address."
  98   (ccl:%ptr-eql ptr1 ptr2))
  99
 100 (defun make-pointer (address)
 101   "Return a pointer pointing to ADDRESS."
 102   (ccl:%int-to-ptr address))
 103
 104 (defun pointer-address (ptr)
 105   "Return the address pointed to by PTR."
 106   (ccl:%ptr-to-int ptr))
 107
 108 ;;;# Shareable Vectors
 109 ;;;
 110 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 111 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 112 ;;; implementation can't do this.
 113
 114 (defun make-shareable-byte-vector (size)
 115   "Create a Lisp vector of SIZE bytes that can passed to
 116 WITH-POINTER-TO-VECTOR-DATA."
 117   (make-array size :element-type '(unsigned-byte 8)))
 118
 119 ;;; from openmcl::macros.lisp
 120
 121 (defmacro with-pointer-to-vector-data ((ptr ivector) &body body)
 122   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 123   (let* ((v (gensym))
 124          (l (gensym)))
 125     `(let* ((,v ,ivector)
 126             (,l (length ,v)))
 127        (unless (typep ,v 'ccl::ivector) (ccl::report-bad-arg ,v 'ccl::ivector))
 128        ;;;!!! this, unless it's possible to suppress gc
 129        (let ((,ptr (#_newPtr ,l)))
 130          (unwind-protect (progn (ccl::%copy-ivector-to-ptr ,v 0 ,ptr 0 ,l)
 131                                 (mutliple-value-prog1
 132                                  (locally ,@body)
 133                                  (ccl::%copy-ptr-to-ivector ,ptr 0 ,v 0 ,l)))
 134            (#_disposePtr ,ptr))))))
 135
 136 ;;;# Dereferencing
 137
 138 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
 139 ;;; macros that optimize the case where the type keyword is constant
 140 ;;; at compile-time.
 141 (defmacro define-mem-accessors (&body pairs)
 142   `(progn
 143     (defun %mem-ref (ptr type &optional (offset 0))
 144       (ecase type
 145         ,@(loop for (keyword fn) in pairs
 146                 collect `(,keyword (,fn ptr offset)))))
 147     (defun %mem-set (value ptr type &optional (offset 0))
 148       (ecase type
 149         ,@(loop for (keyword fn) in pairs
 150                 collect `(,keyword (setf (,fn ptr offset) value)))))
 151     (define-compiler-macro %mem-ref
 152         (&whole form ptr type &optional (offset 0))
 153       (if (constantp type)
 154           (ecase (eval type)
 155             ,@(loop for (keyword fn) in pairs
 156                     collect `(,keyword `(,',fn ,ptr ,offset))))
 157           form))
 158     (define-compiler-macro %mem-set
 159         (&whole form value ptr type &optional (offset 0))
 160       (if (constantp type)
 161           (once-only (value)
 162             (ecase (eval type)
 163               ,@(loop for (keyword fn) in pairs
 164                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
 165                                                 ,value)))))
 166           form))))
 167
 168 (define-mem-accessors
 169   (:char %get-signed-byte)
 170   (:unsigned-char %get-unsigned-byte)
 171   (:short %get-signed-word)
 172   (:unsigned-short %get-unsigned-word)
 173   (:int %get-signed-long)
 174   (:unsigned-int %get-unsigned-long)
 175   (:long %get-signed-long)
 176   (:unsigned-long %get-unsigned-long)
 177   (:long-long ccl::%get-signed-long-long)
 178   (:unsigned-long-long ccl::%get-unsigned-long-long)
 179   (:float %get-single-float)
 180   (:double %get-double-float)
 181   (:pointer %get-ptr))
 182
 183
 184 (defun ccl::%get-unsigned-long-long (ptr offset)
 185   (let ((value 0) (bit 0))
 186     (dotimes (i 8)
 187       (setf (ldb (byte 8 (shiftf bit (+ bit 8))) value)
 188             (ccl:%get-unsigned-byte ptr (+ offset i))))
 189     value))
 190
 191 (setf (fdefinition 'ccl::%get-signed-long-long)
 192       (fdefinition 'ccl::%get-unsigned-long-long))
 193
 194 (defun (setf ccl::%get-unsigned-long-long) (value ptr offset)
 195   (let ((bit 0))
 196     (dotimes (i 8)
 197       (setf (ccl:%get-unsigned-byte ptr (+ offset i))
 198             (ldb (byte 8 (shiftf bit (+ bit 8))) value))))
 199   ptr)
 200
 201 (setf (fdefinition '(setf ccl::%get-signed-long-long))
 202       (fdefinition '(setf ccl::%get-unsigned-long-long)))
 203
 204
 205 ;;;# Calling Foreign Functions
 206
 207 (defun convert-foreign-type (type-keyword)
 208   "Convert a CFFI type keyword to a ppc-ff-call type."
 209   (ecase type-keyword
 210     (:char                :signed-byte)
 211     (:unsigned-char       :unsigned-byte)
 212     (:short               :signed-short)
 213     (:unsigned-short      :unsigned-short)
 214     (:int                 :signed-fullword)
 215     (:unsigned-int        :unsigned-fullword)
 216     (:long                :signed-fullword)
 217     (:unsigned-long       :unsigned-fullword)
 218     (:long-long           :signed-doubleword)
 219     (:unsigned-long-long  :unsigned-doubleword)
 220     (:float               :single-float)
 221     (:double              :double-float)
 222     (:pointer             :address)
 223     (:void                :void)))
 224
 225 (defun ppc-ff-call-type=>mactype-name (type-keyword)
 226   (ecase type-keyword
 227     (:signed-byte          :sint8)
 228     (:unsigned-byte        :uint8)
 229     (:signed-short         :sint16)
 230     (:unsigned-short       :uint16)
 231     (:signed-halfword      :sint16)
 232     (:unsigned-halfword    :uint16)
 233     (:signed-fullword      :sint32)
 234     (:unsigned-fullword    :uint32)
 235     ;(:signed-doubleword    :long-long)
 236     ;(:unsigned-doubleword  :unsigned-long-long)
 237     (:single-float         :single-float)
 238     (:double-float         :double-float)
 239     (:address              :pointer)
 240     (:void                 :void)))
 241
 242
 243
 244 (defun %foreign-type-size (type-keyword)
 245   "Return the size in bytes of a foreign type."
 246   (case type-keyword
 247     ((:long-long :unsigned-long-long) 8)
 248     (t (ccl::mactype-record-size
 249         (ccl::find-mactype
 250          (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
 251
 252 ;; There be dragons here.  See the following thread for details:
 253 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
 254 (defun %foreign-type-alignment (type-keyword)
 255   "Return the alignment in bytes of a foreign type."
 256   (case type-keyword
 257     ((:long-long :unsigned-long-long) 4)
 258     (t (ccl::mactype-record-size
 259         (ccl::find-mactype
 260          (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
 261
 262 (defun convert-foreign-funcall-types (args)
 263   "Convert foreign types for a call to FOREIGN-FUNCALL."
 264   (loop for (type arg) on args by #'cddr
 265         collect (convert-foreign-type type)
 266         if arg collect arg))
 267
 268 (defun convert-external-name (name)
 269   "no '_' is necessary here, the internal lookup operators handle it"
 270   name)
 271
 272 (defmacro %foreign-funcall (function-name args &key library convention)
 273   "Perform a foreign function call, document it more later."
 274   (declare (ignore library convention))
 275   `(ccl::ppc-ff-call
 276     (ccl::macho-address ,(ccl::get-macho-entry-point (convert-external-name function-name)))
 277     ,@(convert-foreign-funcall-types args)))
 278
 279 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 280   (declare (ignore convention))
 281   `(ccl::ppc-ff-call ,ptr ,@(convert-foreign-funcall-types args)))
 282
 283 ;;;# Callbacks
 284
 285 ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
 286 ;;; entry points.  It is safe to store the pointers directly because
 287 ;;; OpenMCL will update the address of these pointers when a saved image
 288 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
 289 (defvar *callbacks* (make-hash-table))
 290
 291 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
 292 ;;; callback for NAME.
 293 (defun intern-callback (name)
 294   (intern (format nil "~A::~A"
 295                   (if-let (package (symbol-package name))
 296                     (package-name package)
 297                     "#")
 298                   (symbol-name name))
 299           '#:cffi-callbacks))
 300
 301 (defmacro %defcallback (name rettype arg-names arg-types body
 302                         &key convention)
 303   (declare (ignore convention))
 304   (let ((cb-name (intern-callback name)))
 305     `(progn
 306        (ccl::ppc-defpascal ,cb-name
 307            (;; ? ,@(when (eq convention :stdcall) '(:discard-stack-args))
 308             ,@(mapcan (lambda (sym type)
 309                         (list (ppc-ff-call-type=>mactype-name (convert-foreign-type type)) sym))
 310                       arg-names arg-types)
 311             ,(ppc-ff-call-type=>mactype-name (convert-foreign-type rettype)))
 312          ,body)
 313        (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
 314
 315 (defun %callback (name)
 316   (or (gethash name *callbacks*)
 317       (error "Undefined callback: ~S" name)))
 318
 319 ;;;# Loading Foreign Libraries
 320
 321 (defun %load-foreign-library (name path)
 322   "Load the foreign library NAME."
 323   (declare (ignore path))
 324   (setf name (string name))
 325   ;; for mcl emulate this wrt frameworks
 326   (unless (and (> (length name) 10)
 327                (string-equal name ".framework" :start1 (- (length name) 10)))
 328     (setf name (concatenate 'string name ".framework")))
 329   ;; if the framework was not registered, add it
 330   (unless (gethash name ccl::*framework-descriptors*)
 331     (ccl::add-framework-bundle name :pathname "ccl:frameworks;" ))
 332   (ccl::load-framework-bundle name))
 333
 334 (defun %close-foreign-library (name)
 335   "Close the foreign library NAME."
 336   ;; for mcl do nothing
 337   (declare (ignore name))
 338   nil)
 339
 340 (defun native-namestring (pathname)
 341   (ccl::posix-namestring (ccl:full-pathname pathname)))
 342
 343
 344 ;;;# Foreign Globals
 345
 346 (deftrap-inline "_findsymbol"
 347     ((map :pointer)
 348      (name :pointer))
 349     :pointer
 350     ())
 351
 352
 353 (defun %foreign-symbol-pointer (name library)
 354   "Returns a pointer to a foreign symbol NAME."
 355   (declare (ignore library))
 356   (ccl::macho-address
 357    (ccl::get-macho-entry-point (convert-external-name name))))