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