src/cffi-lispworks.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-lispworks.lisp --- Lispworks CFFI-SYS implementation.
   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 #-lispworks-64bit (pushnew 'no-long-long *features*)
  33
  34 ;;;# Symbol Case
  35
  36 (defun canonicalize-symbol-name-case (name)
  37   (declare (string name))
  38   (string-upcase name))
  39
  40 ;;;# Basic Pointer Operations
  41
  42 (deftype foreign-pointer ()
  43   'fli::pointer)
  44
  45 (defun pointerp (ptr)
  46   "Return true if PTR is a foreign pointer."
  47   (fli:pointerp ptr))
  48
  49 (defun pointer-eq (ptr1 ptr2)
  50   "Return true if PTR1 and PTR2 point to the same address."
  51   (fli:pointer-eq ptr1 ptr2))
  52
  53 ;; We use FLI:MAKE-POINTER here instead of FLI:*NULL-POINTER* since old
  54 ;; versions of Lispworks don't seem to have it.
  55 (defun null-pointer ()
  56   "Return a null foreign pointer."
  57   (fli:make-pointer :address 0 :type :void))
  58
  59 (defun null-pointer-p (ptr)
  60   "Return true if PTR is a null pointer."
  61   (check-type ptr fli::pointer)
  62   (fli:null-pointer-p ptr))
  63
  64 ;; FLI:INCF-POINTER won't work on FLI pointers to :void so we
  65 ;; increment "manually."
  66 (defun inc-pointer (ptr offset)
  67   "Return a pointer OFFSET bytes past PTR."
  68   (fli:make-pointer :type :void :address (+ (fli:pointer-address ptr) offset)))
  69
  70 (defun make-pointer (address)
  71   "Return a pointer pointing to ADDRESS."
  72   (fli:make-pointer :type :void :address address))
  73
  74 (defun pointer-address (ptr)
  75   "Return the address pointed to by PTR."
  76   (fli:pointer-address ptr))
  77
  78 ;;;# Allocation
  79
  80 (defun %foreign-alloc (size)
  81   "Allocate SIZE bytes of memory and return a pointer."
  82   (fli:allocate-foreign-object :type :byte :nelems size))
  83
  84 (defun foreign-free (ptr)
  85   "Free a pointer PTR allocated by FOREIGN-ALLOC."
  86   (fli:free-foreign-object ptr))
  87
  88 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  89   "Bind VAR to SIZE bytes of foreign memory during BODY.  Both the
  90 pointer in VAR and the memory it points to have dynamic extent and may
  91 be stack allocated if supported by the implementation."
  92   (unless size-var
  93     (setf size-var (gensym "SIZE")))
  94   `(fli:with-dynamic-foreign-objects ()
  95      (let* ((,size-var ,size)
  96             (,var (fli:alloca :type :byte :nelems ,size-var)))
  97        ,@body)))
  98
  99 ;;;# Shareable Vectors
 100
 101 (defun make-shareable-byte-vector (size)
 102   "Create a shareable byte vector."
 103   #+(or lispworks3 lispworks4 lispworks5.0)
 104   (sys:in-static-area
 105     (make-array size :element-type '(unsigned-byte 8)))
 106   #-(or lispworks3 lispworks4 lispworks5.0)
 107   (make-array size :element-type '(unsigned-byte 8) :allocation :static))
 108
 109 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 110   "Bind PTR-VAR to a pointer at the data in VECTOR."
 111   `(fli:with-dynamic-lisp-array-pointer (,ptr-var ,vector)
 112      ,@body))
 113
 114 ;;;# Dereferencing
 115
 116 (defun convert-foreign-type (cffi-type)
 117   "Convert a CFFI type keyword to an FLI type."
 118   (ecase cffi-type
 119     (:char               :byte)
 120     (:unsigned-char      '(:unsigned :byte))
 121     (:short              :short)
 122     (:unsigned-short     '(:unsigned :short))
 123     (:int                :int)
 124     (:unsigned-int       '(:unsigned :int))
 125     (:long               :long)
 126     (:unsigned-long      '(:unsigned :long))
 127     ;; On 32-bit platforms, Lispworks 5.0+ supports long-long for
 128     ;; DEFCFUN and FOREIGN-FUNCALL.
 129     (:long-long          '(:long :long))
 130     (:unsigned-long-long '(:unsigned :long :long))
 131     (:float              :float)
 132     (:double             :double)
 133     (:pointer            :pointer)
 134     (:void               :void)))
 135
 136 ;;; Convert a CFFI type keyword to a symbol suitable for passing to
 137 ;;; FLI:FOREIGN-TYPED-AREF.
 138 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
 139 (defun convert-foreign-typed-aref-type (cffi-type)
 140   (ecase cffi-type
 141     ((:char :short :int :long #+lispworks-64bit :long-long)
 142      `(signed-byte ,(* 8 (%foreign-type-size cffi-type))))
 143     ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long
 144       #+lispworks-64bit :unsigned-long-long)
 145      `(unsigned-byte ,(* 8 (%foreign-type-size cffi-type))))
 146     (:float 'single-float)
 147     (:double 'double-float)))
 148
 149 (defun %mem-ref (ptr type &optional (offset 0))
 150   "Dereference an object of type TYPE OFFSET bytes from PTR."
 151   (unless (zerop offset)
 152     (setf ptr (inc-pointer ptr offset)))
 153   (fli:dereference ptr :type (convert-foreign-type type)))
 154
 155 ;; Lispworks 5.0 on 64-bit platforms doesn't have [u]int64 support in
 156 ;; FOREIGN-TYPED-AREF.  That was implemented in 5.1.
 157 #+(and lispworks-64bit lispworks5.0)
 158 (defun 64-bit-type-p (type)
 159   (member type '(:long :unsigned-long :long-long :unsigned-long-long)))
 160
 161 ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
 162 ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF.
 163 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
 164 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
 165   (if (constantp type)
 166       (let ((type (eval type)))
 167         (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
 168                 (eql type :pointer))
 169             (let ((fli-type (convert-foreign-type type))
 170                   (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
 171               `(fli:dereference ,ptr-form :type ',fli-type))
 172             (let ((lisp-type (convert-foreign-typed-aref-type type)))
 173               `(locally
 174                    (declare (optimize (speed 3) (safety 0)))
 175                  (fli:foreign-typed-aref ',lisp-type ,ptr (the fixnum ,off))))))
 176       form))
 177
 178 ;;; Open-code the call to FLI:DEREFERENCE when TYPE is constant at
 179 ;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available.
 180 #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
 181 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
 182   (if (constantp type)
 183       (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
 184             (type (convert-foreign-type (eval type))))
 185         `(fli:dereference ,ptr-form :type ',type))
 186       form))
 187
 188 (defun %mem-set (value ptr type &optional (offset 0))
 189   "Set the object of TYPE at OFFSET bytes from PTR."
 190   (unless (zerop offset)
 191     (setf ptr (inc-pointer ptr offset)))
 192   (setf (fli:dereference ptr :type (convert-foreign-type type)) value))
 193
 194 ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
 195 ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET.
 196 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
 197 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
 198   (if (constantp type)
 199       (once-only (val)
 200         (let ((type (eval type)))
 201           (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
 202                   (eql type :pointer))
 203               (let ((fli-type (convert-foreign-type type))
 204                     (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
 205                 `(setf (fli:dereference ,ptr-form :type ',fli-type) ,val))
 206               (let ((lisp-type (convert-foreign-typed-aref-type type)))
 207                 `(locally
 208                      (declare (optimize (speed 3) (safety 0)))
 209                    (setf (fli:foreign-typed-aref ',lisp-type ,ptr
 210                                                  (the fixnum ,off))
 211                          ,val))))))
 212       form))
 213
 214 ;;; Open-code the call to (SETF FLI:DEREFERENCE) when TYPE is constant
 215 ;;; at macroexpansion time.
 216 #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
 217 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
 218   (if (constantp type)
 219       (once-only (val)
 220         (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
 221               (type (convert-foreign-type (eval type))))
 222           `(setf (fli:dereference ,ptr-form :type ',type) ,val)))
 223       form))
 224
 225 ;;;# Foreign Type Operations
 226
 227 (defun %foreign-type-size (type)
 228   "Return the size in bytes of a foreign type."
 229   (fli:size-of (convert-foreign-type type)))
 230
 231 (defun %foreign-type-alignment (type)
 232   "Return the structure alignment in bytes of foreign type."
 233   #+(and darwin harp::powerpc)
 234   (when (eq type :double)
 235     (return-from %foreign-type-alignment 8))
 236   ;; Override not necessary for the remaining types...
 237   (fli:align-of (convert-foreign-type type)))
 238
 239 ;;;# Calling Foreign Functions
 240
 241 (defvar *foreign-funcallable-cache* (make-hash-table :test 'equal)
 242   "Caches foreign funcallables created by %FOREIGN-FUNCALL or
 243 %FOREIGN-FUNCALL-POINTER.  We only need to have one per each
 244 signature.")
 245
 246 (defun foreign-funcall-type-and-args (args)
 247   "Returns a list of types, list of args and return type."
 248   (let ((return-type :void))
 249     (loop for (type arg) on args by #'cddr
 250           if arg collect (convert-foreign-type type) into types
 251           and collect arg into fargs
 252           else do (setf return-type (convert-foreign-type type))
 253           finally (return (values types fargs return-type)))))
 254
 255 (defun create-foreign-funcallable (types rettype convention)
 256   "Creates a foreign funcallable for the signature TYPES -> RETTYPE."
 257   #+mac (declare (ignore convention))
 258   (format t "~&Creating foreign funcallable for signature ~S -> ~S~%"
 259           types rettype)
 260   ;; yes, ugly, this most likely wants to be a top-level form...
 261   (let ((internal-name (gensym)))
 262     (funcall
 263      (compile nil
 264               `(lambda ()
 265                  (fli:define-foreign-funcallable ,internal-name
 266                      ,(loop for type in types
 267                             collect (list (gensym) type))
 268                    :result-type ,rettype
 269                    :language :ansi-c
 270                    ;; avoid warning about cdecl not being supported on mac
 271                    #-mac ,@(list :calling-convention convention)))))
 272     internal-name))
 273
 274 (defun get-foreign-funcallable (types rettype convention)
 275   "Returns a foreign funcallable for the signature TYPES -> RETTYPE -
 276 either from the cache or newly created."
 277   (let ((signature (cons rettype types)))
 278     (or (gethash signature *foreign-funcallable-cache*)
 279         ;; (SETF GETHASH) is supposed to be thread-safe
 280         (setf (gethash signature *foreign-funcallable-cache*)
 281               (create-foreign-funcallable types rettype convention)))))
 282
 283 (defmacro %%foreign-funcall (foreign-function args convention)
 284   "Does the actual work for %FOREIGN-FUNCALL-POINTER and %FOREIGN-FUNCALL.
 285 Checks if a foreign funcallable which fits ARGS already exists and creates
 286 and caches it if necessary.  Finally calls it."
 287   (multiple-value-bind (types fargs rettype)
 288       (foreign-funcall-type-and-args args)
 289     `(funcall (load-time-value
 290                (get-foreign-funcallable ',types ',rettype ',convention))
 291               ,foreign-function ,@fargs)))
 292
 293 (defmacro %foreign-funcall (name args &key library convention)
 294   "Calls a foreign function named NAME passing arguments ARGS."
 295   `(%%foreign-funcall
 296     (fli:make-pointer :symbol-name ,name
 297                       :module ',(if (eq library :default) nil library))
 298     ,args ,convention))
 299
 300 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 301   "Calls a foreign function pointed at by PTR passing arguments ARGS."
 302   `(%%foreign-funcall ,ptr ,args ,convention))
 303
 304 (defun defcfun-helper-forms (name lisp-name rettype args types options)
 305   "Return 2 values for DEFCFUN. A prelude form and a caller form."
 306   (let ((ff-name (intern (format nil "%cffi-foreign-function/~A"  lisp-name))))
 307     (values
 308      `(fli:define-foreign-function (,ff-name ,name :source)
 309           ,(mapcar (lambda (ty) (list (gensym) (convert-foreign-type ty)))
 310                    types)
 311         :result-type ,(convert-foreign-type rettype)
 312         :language :ansi-c
 313         :module ',(let ((lib (getf options :library)))
 314                     (if (eq lib :default) nil lib))
 315         ;; avoid warning about cdecl not being supported on mac platforms
 316         #-mac ,@(list :calling-convention (getf options :convention)))
 317      `(,ff-name ,@args))))
 318
 319 ;;;# Callbacks
 320
 321 (defvar *callbacks* (make-hash-table))
 322
 323 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
 324 ;;; callback for NAME.
 325 (eval-when (:compile-toplevel :load-toplevel :execute)
 326   (defun intern-callback (name)
 327     (intern (format nil "~A::~A"
 328                     (if-let (package (symbol-package name))
 329                       (package-name package)
 330                       "#")
 331                     (symbol-name name))
 332             '#:cffi-callbacks)))
 333
 334 (defmacro %defcallback (name rettype arg-names arg-types body
 335                         &key convention)
 336   (let ((cb-name (intern-callback name)))
 337     `(progn
 338        (fli:define-foreign-callable
 339            (,cb-name :encode :lisp
 340                      :result-type ,(convert-foreign-type rettype)
 341                      :calling-convention ,convention
 342                      :language :ansi-c
 343                      :no-check nil)
 344            ,(mapcar (lambda (sym type)
 345                       (list sym (convert-foreign-type type)))
 346                     arg-names arg-types)
 347          ,body)
 348        (setf (gethash ',name *callbacks*) ',cb-name))))
 349
 350 (defun %callback (name)
 351   (multiple-value-bind (symbol winp)
 352       (gethash name *callbacks*)
 353     (unless winp
 354       (error "Undefined callback: ~S" name))
 355     (fli:make-pointer :symbol-name symbol :module :callbacks)))
 356
 357 ;;;# Loading Foreign Libraries
 358
 359 (defun %load-foreign-library (name path)
 360   "Load the foreign library NAME."
 361   (fli:register-module (or name path) :connection-style :immediate
 362                        :real-name path))
 363
 364 (defun %close-foreign-library (name)
 365   "Close the foreign library NAME."
 366   (fli:disconnect-module name :remove t))
 367
 368 (defun native-namestring (pathname)
 369   (namestring pathname))
 370
 371 ;;;# Foreign Globals
 372
 373 (defun %foreign-symbol-pointer (name library)
 374   "Returns a pointer to a foreign symbol NAME."
 375   (values
 376    (ignore-errors
 377      (fli:make-pointer :symbol-name name :type :void
 378                        :module (if (eq library :default) nil library)))))