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 ;;;# Administrivia
  41
  42 (defpackage #:cffi-sys
  43   (:use #:common-lisp #:ccl)
  44   (:import-from #:alexandria #:once-only #:if-let)
  45   (:export
  46    #:canonicalize-symbol-name-case
  47    #:foreign-pointer
  48    #:pointerp  ; ccl:pointerp
  49    #:pointer-eq
  50    #:%foreign-alloc
  51    #:foreign-free
  52    #:with-foreign-pointer
  53    #:null-pointer
  54    #:null-pointer-p
  55    #:inc-pointer
  56    #:make-pointer
  57    #:pointer-address
  58    #:%mem-ref
  59    #:%mem-set
  60    #:%foreign-funcall
  61    #:%foreign-funcall-pointer
  62    #:%foreign-type-alignment
  63    #:%foreign-type-size
  64    #:%load-foreign-library
  65    #:%close-foreign-library
  66    #:native-namestring
  67    #:make-shareable-byte-vector
  68    #:with-pointer-to-vector-data
  69    #:%foreign-symbol-pointer
  70    #:%defcallback
  71    #:%callback))
  72
  73 (in-package #:cffi-sys)
  74
  75 ;;;# Misfeatures
  76
  77 (pushnew 'flat-namespace *features*)
  78
  79 ;;;# Symbol Case
  80
  81 (defun canonicalize-symbol-name-case (name)
  82   (declare (string name))
  83   (string-upcase name))
  84
  85 ;;;# Allocation
  86 ;;;
  87 ;;; Functions and macros for allocating foreign memory on the stack
  88 ;;; and on the heap.  The main CFFI package defines macros that wrap
  89 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
  90 ;;; usage when the memory has dynamic extent.
  91
  92 (defun %foreign-alloc (size)
  93   "Allocate SIZE bytes on the heap and return a pointer."
  94   (#_newPtr size))
  95
  96 (defun foreign-free (ptr)
  97   "Free a PTR allocated by FOREIGN-ALLOC."
  98   ;; TODO: Should we make this a dead macptr?
  99   (#_disposePtr ptr))
 100
 101 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 102   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
 103 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 104 may be stack-allocated if supported by the implementation.  If
 105 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 106   (unless size-var
 107     (setf size-var (gensym "SIZE")))
 108   `(let ((,size-var ,size))
 109      (ccl:%stack-block ((,var ,size-var))
 110        ,@body)))
 111
 112 ;;;# Misc. Pointer Operations
 113
 114 (deftype foreign-pointer ()
 115   'ccl:macptr)
 116
 117 (defun null-pointer ()
 118   "Construct and return a null pointer."
 119   (ccl:%null-ptr))
 120
 121 (defun null-pointer-p (ptr)
 122   "Return true if PTR is a null pointer."
 123   (ccl:%null-ptr-p ptr))
 124
 125 (defun inc-pointer (ptr offset)
 126   "Return a pointer OFFSET bytes past PTR."
 127   (ccl:%inc-ptr ptr offset))
 128
 129 (defun pointer-eq (ptr1 ptr2)
 130   "Return true if PTR1 and PTR2 point to the same address."
 131   (ccl:%ptr-eql ptr1 ptr2))
 132
 133 (defun make-pointer (address)
 134   "Return a pointer pointing to ADDRESS."
 135   (ccl:%int-to-ptr address))
 136
 137 (defun pointer-address (ptr)
 138   "Return the address pointed to by PTR."
 139   (ccl:%ptr-to-int ptr))
 140
 141 ;;;# Shareable Vectors
 142 ;;;
 143 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 144 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 145 ;;; implementation can't do this.
 146
 147 (defun make-shareable-byte-vector (size)
 148   "Create a Lisp vector of SIZE bytes that can passed to
 149 WITH-POINTER-TO-VECTOR-DATA."
 150   (make-array size :element-type '(unsigned-byte 8)))
 151
 152 ;;; from openmcl::macros.lisp
 153
 154 (defmacro with-pointer-to-vector-data ((ptr ivector) &body body)
 155   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 156   (let* ((v (gensym))
 157          (l (gensym)))
 158     `(let* ((,v ,ivector)
 159             (,l (length ,v)))
 160        (unless (typep ,v 'ccl::ivector) (ccl::report-bad-arg ,v 'ccl::ivector))
 161        ;;;!!! this, unless it's possible to suppress gc
 162        (let ((,ptr (#_newPtr ,l)))
 163          (unwind-protect (progn (ccl::%copy-ivector-to-ptr ,v 0 ,ptr 0 ,l)
 164                                 (mutliple-value-prog1
 165                                  (locally ,@body)
 166                                  (ccl::%copy-ptr-to-ivector ,ptr 0 ,v 0 ,l)))
 167            (#_disposePtr ,ptr))))))
 168
 169 ;;;# Dereferencing
 170
 171 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
 172 ;;; macros that optimize the case where the type keyword is constant
 173 ;;; at compile-time.
 174 (defmacro define-mem-accessors (&body pairs)
 175   `(progn
 176     (defun %mem-ref (ptr type &optional (offset 0))
 177       (ecase type
 178         ,@(loop for (keyword fn) in pairs
 179                 collect `(,keyword (,fn ptr offset)))))
 180     (defun %mem-set (value ptr type &optional (offset 0))
 181       (ecase type
 182         ,@(loop for (keyword fn) in pairs
 183                 collect `(,keyword (setf (,fn ptr offset) value)))))
 184     (define-compiler-macro %mem-ref
 185         (&whole form ptr type &optional (offset 0))
 186       (if (constantp type)
 187           (ecase (eval type)
 188             ,@(loop for (keyword fn) in pairs
 189                     collect `(,keyword `(,',fn ,ptr ,offset))))
 190           form))
 191     (define-compiler-macro %mem-set
 192         (&whole form value ptr type &optional (offset 0))
 193       (if (constantp type)
 194           (once-only (value)
 195             (ecase (eval type)
 196               ,@(loop for (keyword fn) in pairs
 197                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
 198                                                 ,value)))))
 199           form))))
 200
 201 (define-mem-accessors
 202   (:char %get-signed-byte)
 203   (:unsigned-char %get-unsigned-byte)
 204   (:short %get-signed-word)
 205   (:unsigned-short %get-unsigned-word)
 206   (:int %get-signed-long)
 207   (:unsigned-int %get-unsigned-long)
 208   (:long %get-signed-long)
 209   (:unsigned-long %get-unsigned-long)
 210   (:long-long ccl::%get-signed-long-long)
 211   (:unsigned-long-long ccl::%get-unsigned-long-long)
 212   (:float %get-single-float)
 213   (:double %get-double-float)
 214   (:pointer %get-ptr))
 215
 216
 217 (defun ccl::%get-unsigned-long-long (ptr offset)
 218   (let ((value 0) (bit 0))
 219     (dotimes (i 8)
 220       (setf (ldb (byte 8 (shiftf bit (+ bit 8))) value)
 221             (ccl:%get-unsigned-byte ptr (+ offset i))))
 222     value))
 223
 224 (setf (fdefinition 'ccl::%get-signed-long-long)
 225       (fdefinition 'ccl::%get-unsigned-long-long))
 226
 227 (defun (setf ccl::%get-unsigned-long-long) (value ptr offset)
 228   (let ((bit 0))
 229     (dotimes (i 8)
 230       (setf (ccl:%get-unsigned-byte ptr (+ offset i))
 231             (ldb (byte 8 (shiftf bit (+ bit 8))) value))))
 232   ptr)
 233
 234 (setf (fdefinition '(setf ccl::%get-signed-long-long))
 235       (fdefinition '(setf ccl::%get-unsigned-long-long)))
 236
 237
 238 ;;;# Calling Foreign Functions
 239
 240 (defun convert-foreign-type (type-keyword)
 241   "Convert a CFFI type keyword to a ppc-ff-call type."
 242   (ecase type-keyword
 243     (:char                :signed-byte)
 244     (:unsigned-char       :unsigned-byte)
 245     (:short               :signed-short)
 246     (:unsigned-short      :unsigned-short)
 247     (:int                 :signed-fullword)
 248     (:unsigned-int        :unsigned-fullword)
 249     (:long                :signed-fullword)
 250     (:unsigned-long       :unsigned-fullword)
 251     (:long-long           :signed-doubleword)
 252     (:unsigned-long-long  :unsigned-doubleword)
 253     (:float               :single-float)
 254     (:double              :double-float)
 255     (:pointer             :address)
 256     (:void                :void)))
 257
 258 (defun ppc-ff-call-type=>mactype-name (type-keyword)
 259   (ecase type-keyword
 260     (:signed-byte          :sint8)
 261     (:unsigned-byte        :uint8)
 262     (:signed-short         :sint16)
 263     (:unsigned-short       :uint16)
 264     (:signed-halfword      :sint16)
 265     (:unsigned-halfword    :uint16)
 266     (:signed-fullword      :sint32)
 267     (:unsigned-fullword    :uint32)
 268     ;(:signed-doubleword    :long-long)
 269     ;(:unsigned-doubleword  :unsigned-long-long)
 270     (:single-float         :single-float)
 271     (:double-float         :double-float)
 272     (:address              :pointer)
 273     (:void                 :void)))
 274
 275
 276
 277 (defun %foreign-type-size (type-keyword)
 278   "Return the size in bytes of a foreign type."
 279   (case type-keyword
 280     ((:long-long :unsigned-long-long) 8)
 281     (t (ccl::mactype-record-size
 282         (ccl::find-mactype
 283          (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
 284
 285 ;; There be dragons here.  See the following thread for details:
 286 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
 287 (defun %foreign-type-alignment (type-keyword)
 288   "Return the alignment in bytes of a foreign type."
 289   (case type-keyword
 290     ((:long-long :unsigned-long-long) 4)
 291     (t (ccl::mactype-record-size
 292         (ccl::find-mactype
 293          (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
 294
 295 (defun convert-foreign-funcall-types (args)
 296   "Convert foreign types for a call to FOREIGN-FUNCALL."
 297   (loop for (type arg) on args by #'cddr
 298         collect (convert-foreign-type type)
 299         if arg collect arg))
 300
 301 (defun convert-external-name (name)
 302   "no '_' is necessary here, the internal lookup operators handle it"
 303   name)
 304
 305 (defmacro %foreign-funcall (function-name args &key library convention)
 306   "Perform a foreign function call, document it more later."
 307   (declare (ignore library convention))
 308   `(ccl::ppc-ff-call
 309     (ccl::macho-address ,(ccl::get-macho-entry-point (convert-external-name function-name)))
 310     ,@(convert-foreign-funcall-types args)))
 311
 312 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 313   (declare (ignore convention))
 314   `(ccl::ppc-ff-call ,ptr ,@(convert-foreign-funcall-types args)))
 315
 316 ;;;# Callbacks
 317
 318 ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
 319 ;;; entry points.  It is safe to store the pointers directly because
 320 ;;; OpenMCL will update the address of these pointers when a saved image
 321 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
 322 (defvar *callbacks* (make-hash-table))
 323
 324 ;;; Create a package to contain the symbols for callback functions.  We
 325 ;;; want to redefine callbacks with the same symbol so the internal data
 326 ;;; structures are reused.
 327 (defpackage #:cffi-callbacks
 328   (:use))
 329
 330 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
 331 ;;; callback for NAME.
 332 (defun intern-callback (name)
 333   (intern (format nil "~A::~A"
 334                   (if-let (package (symbol-package name))
 335                     (package-name package)
 336                     "#")
 337                   (symbol-name name))
 338           '#:cffi-callbacks))
 339
 340 (defmacro %defcallback (name rettype arg-names arg-types body
 341                         &key convention)
 342   (declare (ignore convention))
 343   (let ((cb-name (intern-callback name)))
 344     `(progn
 345        (ccl::ppc-defpascal ,cb-name
 346            (;; ? ,@(when (eq convention :stdcall) '(:discard-stack-args))
 347             ,@(mapcan (lambda (sym type)
 348                         (list (ppc-ff-call-type=>mactype-name (convert-foreign-type type)) sym))
 349                       arg-names arg-types)
 350             ,(ppc-ff-call-type=>mactype-name (convert-foreign-type rettype)))
 351          ,body)
 352        (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
 353
 354 (defun %callback (name)
 355   (or (gethash name *callbacks*)
 356       (error "Undefined callback: ~S" name)))
 357
 358 ;;;# Loading Foreign Libraries
 359
 360 (defun %load-foreign-library (name path)
 361   "Load the foreign library NAME."
 362   (declare (ignore path))
 363   (setf name (string name))
 364   ;; for mcl emulate this wrt frameworks
 365   (unless (and (> (length name) 10)
 366                (string-equal name ".framework" :start1 (- (length name) 10)))
 367     (setf name (concatenate 'string name ".framework")))
 368   ;; if the framework was not registered, add it
 369   (unless (gethash name ccl::*framework-descriptors*)
 370     (ccl::add-framework-bundle name :pathname "ccl:frameworks;" ))
 371   (ccl::load-framework-bundle name))
 372
 373 (defun %close-foreign-library (name)
 374   "Close the foreign library NAME."
 375   ;; for mcl do nothing
 376   (declare (ignore name))
 377   nil)
 378
 379 (defun native-namestring (pathname)
 380   (ccl::posix-namestring (ccl:full-pathname pathname)))
 381
 382
 383 ;;;# Foreign Globals
 384
 385 (deftrap-inline "_findsymbol"
 386     ((map :pointer)
 387      (name :pointer))
 388     :pointer
 389     ())
 390
 391
 392 (defun %foreign-symbol-pointer (name library)
 393   "Returns a pointer to a foreign symbol NAME."
 394   (declare (ignore library))
 395   (ccl::macho-address
 396    (ccl::get-macho-entry-point (convert-external-name name))))