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