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