src/cffi-ecl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-ecl.lisp --- ECL backend for CFFI.
   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 ;;;
  31 ;;; ECL allows many ways of calling a foreign function, and also many
  32 ;;; ways of finding the pointer associated to a function name. They
  33 ;;; depend on whether the FFI relies on libffi or on the C/C++ compiler,
  34 ;;; and whether they use the shared library loader to locate symbols
  35 ;;; or they are linked by the linker.
  36 ;;;
  37 ;;;  :DFFI
  38 ;;;
  39 ;;;  ECL uses libffi to call foreign functions. The only way to find out
  40 ;;;  foreign symbols is by loading shared libraries and using dlopen()
  41 ;;;  or similar.
  42 ;;;
  43 ;;;  :DLOPEN
  44 ;;;
  45 ;;;  ECL compiles FFI code as C/C++ statements. The names are resolved
  46 ;;;  at run time by the shared library loader every time the function
  47 ;;;  is called
  48 ;;;
  49 ;;;  :C/C++
  50 ;;;
  51 ;;;  ECL compiles FFI code as C/C++ statements, but the name resolution
  52 ;;;  happens at link time. In this case you have to tell the ECL
  53 ;;;  compiler which are the right ld-flags (c:*ld-flags*) to link in
  54 ;;;  the library.
  55 ;;;
  56 (defvar *cffi-ecl-method*
  57   #+dffi :dffi
  58   #+(and dlopen (not dffi)) :dlopen
  59   #-(or dffi dlopen) :c/c++
  60   "The type of code that CFFI generates for ECL: :DFFI when using the
  61 dynamical foreign function interface; :DLOPEN when using C code and
  62 dynamical references to symbols; :C/C++ for C/C++ code with static
  63 references to symbols.")
  64
  65 ;;;# Mis-features
  66
  67 #-long-long
  68 (pushnew 'no-long-long *features*)
  69 (pushnew 'flat-namespace *features*)
  70
  71 ;;;# Symbol Case
  72
  73 (defun canonicalize-symbol-name-case (name)
  74   (declare (string name))
  75   (string-upcase name))
  76
  77 ;;;# Allocation
  78
  79 (defun %foreign-alloc (size)
  80   "Allocate SIZE bytes of foreign-addressable memory."
  81   (si:allocate-foreign-data :void size))
  82
  83 (defun foreign-free (ptr)
  84   "Free a pointer PTR allocated by FOREIGN-ALLOC."
  85   (si:free-foreign-data ptr))
  86
  87 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  88   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  89 pointer in VAR is invalid beyond the dynamic extent of BODY, and
  90 may be stack-allocated if supported by the implementation.  If
  91 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
  92   (unless size-var
  93     (setf size-var (gensym "SIZE")))
  94   `(let* ((,size-var ,size)
  95           (,var (%foreign-alloc ,size-var)))
  96      (unwind-protect
  97           (progn ,@body)
  98        (foreign-free ,var))))
  99
 100 ;;;# Misc. Pointer Operations
 101
 102 (deftype foreign-pointer ()
 103   'si:foreign-data)
 104
 105 (defun null-pointer ()
 106   "Construct and return a null pointer."
 107   (si:allocate-foreign-data :void 0))
 108
 109 (defun inc-pointer (ptr offset)
 110   "Return a pointer OFFSET bytes past PTR."
 111   (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
 112
 113 (defun pointerp (ptr)
 114   "Return true if PTR is a foreign pointer."
 115   (typep ptr 'si:foreign-data))
 116
 117 (defun pointer-eq (ptr1 ptr2)
 118   "Return true if PTR1 and PTR2 point to the same address."
 119   (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
 120
 121 (defun make-pointer (address)
 122   "Return a pointer pointing to ADDRESS."
 123   (ffi:make-pointer address :void))
 124
 125 (defun pointer-address (ptr)
 126   "Return the address pointed to by PTR."
 127   (ffi:pointer-address ptr))
 128
 129 ;;;# Shareable Vectors
 130 ;;;
 131 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 132 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 133 ;;; implementation can't do this.
 134
 135 (defun make-shareable-byte-vector (size)
 136   "Create a Lisp vector of SIZE bytes that can passed to
 137 WITH-POINTER-TO-VECTOR-DATA."
 138   (make-array size :element-type '(unsigned-byte 8)))
 139
 140 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 141   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 142   `(let ((,ptr-var (si:make-foreign-data-from-array ,vector)))
 143      ,@body))
 144
 145 ;;;# Type Operations
 146
 147 (defconstant +translation-table+
 148   '((:char            :byte            "char")
 149     (:unsigned-char   :unsigned-byte   "unsigned char")
 150     (:short           :short           "short")
 151     (:unsigned-short  :unsigned-short  "unsigned short")
 152     (:int             :int             "int")
 153     (:unsigned-int    :unsigned-int    "unsigned int")
 154     (:long            :long            "long")
 155     (:unsigned-long   :unsigned-long   "unsigned long")
 156     #+long-long
 157     (:long-long       :long-long       "long long")
 158     #+long-long
 159     (:unsigned-long-long :unsigned-long-long "unsigned long long")
 160     (:float           :float           "float")
 161     (:double          :double          "double")
 162     #+long-float
 163     (:long-double     :long-double     "long double")
 164     (:pointer         :pointer-void    "void*")
 165     (:void            :void            "void")))
 166
 167 (defun cffi-type->ecl-type (type-keyword)
 168   "Convert a CFFI type keyword to an ECL type keyword."
 169   (or (second (find type-keyword +translation-table+ :key #'first))
 170       (error "~S is not a valid CFFI type" type-keyword)))
 171
 172 (defun ecl-type->c-type (type-keyword)
 173   "Convert a CFFI type keyword to an valid C type keyword."
 174   (or (third (find type-keyword +translation-table+ :key #'second))
 175       (error "~S is not a valid CFFI type" type-keyword)))
 176
 177 (defun %foreign-type-size (type-keyword)
 178   "Return the size in bytes of a foreign type."
 179   (nth-value 0 (ffi:size-of-foreign-type
 180                 (cffi-type->ecl-type type-keyword))))
 181
 182 (defun %foreign-type-alignment (type-keyword)
 183   "Return the alignment in bytes of a foreign type."
 184   (nth-value 1 (ffi:size-of-foreign-type
 185                 (cffi-type->ecl-type type-keyword))))
 186
 187 ;;;# Dereferencing
 188
 189 (defun %mem-ref (ptr type &optional (offset 0))
 190   "Dereference an object of TYPE at OFFSET bytes from PTR."
 191   (let* ((type (cffi-type->ecl-type type))
 192          (type-size (ffi:size-of-foreign-type type)))
 193     (si:foreign-data-ref-elt
 194      (si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
 195
 196 (defun %mem-set (value ptr type &optional (offset 0))
 197   "Set an object of TYPE at OFFSET bytes from PTR."
 198   (let* ((type (cffi-type->ecl-type type))
 199          (type-size (ffi:size-of-foreign-type type)))
 200     (si:foreign-data-set-elt
 201      (si:foreign-data-recast ptr (+ offset type-size) :void)
 202      offset type value)))
 203
 204 ;;; Inline versions that use C expressions instead of function calls.
 205
 206 (defparameter +mem-ref-strings+
 207   (loop for (cffi-type ecl-type c-string) in +translation-table+
 208         for string = (format nil "*((~A *)(((char*)#0)+#1))" c-string)
 209         collect (list cffi-type ecl-type string)))
 210
 211 (defparameter +mem-set-strings+
 212   (loop for (cffi-type ecl-type c-string) in +translation-table+
 213         for string = (format nil "*((~A *)(((char*)#0)+#1))=#2" c-string)
 214         collect (list cffi-type ecl-type string)))
 215
 216 (define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset 0))
 217   (if (and (constantp type) (constantp offset))
 218       (let ((record (assoc (eval type) +mem-ref-strings+)))
 219         `(ffi:c-inline (,ptr ,offset)
 220                        (:pointer-void :cl-index) ; argument types
 221                        ,(second record)          ; return type
 222                        ,(third record)  ; the precomputed expansion
 223                        :one-liner t))
 224       whole))
 225
 226 (define-compiler-macro %mem-set (&whole whole value ptr type &optional (offset 0))
 227   (if (and (constantp type) (constantp offset))
 228       (let ((record (assoc (eval type) +mem-set-strings+)))
 229         `(ffi:c-inline (,ptr ,offset ,value) ; arguments with type translated
 230                        (:pointer-void :cl-index ,(second record))
 231                        :void            ; does not return anything
 232                        ,(third record)  ; precomputed expansion
 233                        :one-liner t))
 234       whole))
 235
 236 ;;;# Calling Foreign Functions
 237
 238 (defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
 239
 240 (defun c-inline-function-call (thing fixed-types types values return-type dynamic-call variadic)
 241   (when dynamic-call
 242     (when (stringp thing)
 243       (setf thing `(%foreign-symbol-pointer ,thing nil)))
 244     (push thing values)
 245     (push :pointer-void types))
 246   (let* ((decl-args
 247           (format nil "~{~A~^, ~}~A"
 248                   (mapcar #'ecl-type->c-type fixed-types) (if (null variadic) "" ", ...")))
 249          (call-args
 250           (if dynamic-call
 251               ;; #0 is already used in a cast (it is a function pointer)
 252               (subseq +ecl-inline-codes+ 3 (max 3 (1- (* (length values) 3))))
 253               ;; #0 is not used, so we start from the beginning
 254               (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3))))))
 255          (clines
 256           (if dynamic-call
 257               nil
 258               (format nil "extern ~A ~A(~A);"
 259                       (ecl-type->c-type return-type) thing decl-args)))
 260          (call-code
 261           (if dynamic-call
 262               (format nil "((~A (*)(~A))(#0))(~A)"
 263                       (ecl-type->c-type return-type) decl-args call-args)
 264               (format nil "~A(~A)" thing call-args))))
 265     `(progn
 266        (ffi:clines ,@(ensure-list clines))
 267        (ffi:c-inline ,values ,types ,return-type ,call-code :one-liner t :side-effects t))))
 268
 269 (defun dffi-function-pointer-call (pointer types values return-type)
 270   (when (stringp pointer)
 271     (setf pointer `(%foreign-symbol-pointer ,pointer nil)))
 272   #-dffi
 273   `(error "In interpreted code, attempted to call a foreign function~% ~A~%~
 274              but ECL was built without support for that." ,pointer)
 275   #+dffi
 276   `(si::call-cfun ,pointer ,return-type (list ,@types) (list ,@values)))
 277
 278 (defun foreign-funcall-parse-args (args)
 279   "Return three values, lists of arg types, values, and result type."
 280   (let ((return-type :void))
 281     (loop for (type arg) on args by #'cddr
 282           if arg collect (cffi-type->ecl-type type) into types
 283           and collect arg into values
 284           else do (setf return-type (cffi-type->ecl-type type))
 285           finally (return (values types values return-type)))))
 286
 287 (defmacro %foreign-funcall (name args &key library convention)
 288   "Call a foreign function."
 289   (declare (ignore library convention))
 290   (multiple-value-bind (types values return-type)
 291       (foreign-funcall-parse-args args)
 292     `(ext:with-backend
 293       :bytecodes
 294       ,(dffi-function-pointer-call name types values return-type)
 295       :c/c++
 296       ,(ecase *cffi-ecl-method*
 297          (:dffi   (dffi-function-pointer-call name types values return-type))
 298          (:dlopen (c-inline-function-call name types types values return-type t nil))
 299          (:c/c++  (c-inline-function-call name types types values return-type nil nil))))))
 300
 301 (defmacro %foreign-funcall-pointer (pointer args &key convention)
 302   "Funcall a pointer to a foreign function."
 303   (declare (ignore convention))
 304   (multiple-value-bind (types values return-type)
 305       (foreign-funcall-parse-args args)
 306     `(ext:with-backend
 307       :bytecodes
 308       ,(dffi-function-pointer-call pointer types values return-type)
 309       :c/c++
 310       ,(if (eq *cffi-ecl-method* :dffi)
 311            (dffi-function-pointer-call pointer types values return-type)
 312            (c-inline-function-call pointer types types values return-type t nil)))))
 313
 314 (defmacro %foreign-funcall-varargs (name args varargs &key library convention)
 315   (declare (ignore library convention))
 316   (multiple-value-bind (fixed-types fixed-values)
 317       (foreign-funcall-parse-args args)
 318     (multiple-value-bind (varargs-types varargs-values return-type)
 319         (foreign-funcall-parse-args varargs)
 320       (let ((all-types (append fixed-types varargs-types))
 321             (values (append fixed-values varargs-values)))
 322        `(ext:with-backend
 323          :bytecodes
 324          ,(dffi-function-pointer-call name all-types values return-type)
 325          :c/c++
 326          ,(ecase *cffi-ecl-method*
 327             (:dffi   (dffi-function-pointer-call name all-types values return-type))
 328             (:dlopen (c-inline-function-call name fixed-types all-types values return-type t t))
 329             (:c/c++  (c-inline-function-call name fixed-types all-types values return-type nil t))))))))
 330
 331 (defmacro %foreign-funcall-pointer-varargs (pointer args varargs &key convention)
 332   (declare (ignore convention))
 333   (multiple-value-bind (fixed-types fixed-values)
 334       (foreign-funcall-parse-args args)
 335     (multiple-value-bind (varargs-types varargs-values return-type)
 336         (foreign-funcall-parse-args varargs)
 337       (let ((all-types (append fixed-types varargs-types))
 338             (values (append fixed-values varargs-values)))
 339        `(ext:with-backend
 340          :bytecodes
 341          ,(dffi-function-pointer-call pointer all-types values return-type)
 342          :c/c++
 343          ,(if (eq *cffi-ecl-method* :dffi)
 344             (dffi-function-pointer-call pointer all-types values return-type)
 345             (c-inline-function-call pointer fixed-types all-types values return-type t t)))))))
 346
 347 ;;;# Foreign Libraries
 348
 349 (defun %load-foreign-library (name path)
 350   "Load a foreign library."
 351   (declare (ignore name))
 352   #-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
 353                  FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.")
 354   #+dffi
 355   (handler-case (si:load-foreign-module path)
 356     (file-error ()
 357       (error "file error while trying to load `~A'" path))))
 358
 359 (defun %close-foreign-library (handle)
 360   "Close a foreign library."
 361   (handler-case (si::unload-foreign-module handle)
 362     (undefined-function ()
 363       (restart-case (error "Detected ECL prior to version 15.2.21. ~
 364                             Function CFFI:CLOSE-FOREIGN-LIBRARY isn't implemented yet.")
 365         (ignore () :report "Continue anyway (foreign library will remain opened).")))))
 366
 367 (defun native-namestring (pathname)
 368   (namestring pathname))
 369
 370 ;;;# Callbacks
 371
 372 (defvar *callbacks* (make-hash-table))
 373
 374 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
 375 ;;; internal callback for NAME.
 376 (eval-when (:compile-toplevel :load-toplevel :execute)
 377   (defun intern-callback (name)
 378     (intern (format nil "~A::~A"
 379                     (if-let (package (symbol-package name))
 380                       (package-name package)
 381                       "#")
 382                     (symbol-name name))
 383             '#:cffi-callbacks)))
 384
 385 (defmacro %defcallback (name rettype arg-names arg-types body
 386                         &key convention)
 387   (declare (ignore convention))
 388   (let ((cb-name (intern-callback name))
 389         (cb-type #.(if (> ext:+ecl-version-number+ 160102)
 390                        :default :cdecl)))
 391     `(progn
 392        (ffi:defcallback (,cb-name ,cb-type)
 393            ,(cffi-type->ecl-type rettype)
 394            ,(mapcar #'list arg-names
 395                     (mapcar #'cffi-type->ecl-type arg-types))
 396          ,body)
 397        (setf (gethash ',name *callbacks*) ',cb-name))))
 398
 399 (defun %callback (name)
 400   (multiple-value-bind (symbol winp)
 401       (gethash name *callbacks*)
 402     (unless winp
 403       (error "Undefined callback: ~S" name))
 404     (ffi:callback symbol)))
 405
 406 ;;;# Foreign Globals
 407
 408 (defun %foreign-symbol-pointer (name library)
 409   "Returns a pointer to a foreign symbol NAME."
 410   (declare (ignore library))
 411   (handler-case
 412       (si:find-foreign-symbol (coerce name 'base-string)
 413                               :default :pointer-void 0)
 414     (error (c) nil)))