libffi/funcall.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; funcall.lisp -- FOREIGN-FUNCALL implementation using libffi
   4 ;;;
   5 ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy  <lhealy@common-lisp.net>
   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)
  29
  30 (define-condition libffi-error (cffi-error)
  31   ((function-name
  32     :initarg :function-name :reader function-name)))
  33
  34 (define-condition simple-libffi-error (simple-error libffi-error)
  35   ())
  36
  37 (defun libffi-error (function-name format-control &rest format-arguments)
  38   (error 'simple-libffi-error
  39          :function-name function-name
  40          :format-control format-control
  41          :format-arguments format-arguments))
  42
  43 (defun make-libffi-cif (function-name return-type argument-types
  44                         &optional (abi :default-abi))
  45   "Generate or retrieve the Call InterFace needed to call the function through libffi."
  46   (let* ((argument-count (length argument-types))
  47          (cif (foreign-alloc '(:struct ffi-cif)))
  48          (ffi-argtypes (foreign-alloc :pointer :count argument-count)))
  49     (loop
  50       :for type :in argument-types
  51       :for index :from 0
  52       :do (setf (mem-aref ffi-argtypes :pointer index)
  53                 (make-libffi-type-descriptor (parse-type type))))
  54     (unless (eql :ok (libffi/prep-cif cif abi argument-count
  55                                       (make-libffi-type-descriptor (parse-type return-type))
  56                                       ffi-argtypes))
  57       (libffi-error function-name
  58                     "The 'ffi_prep_cif' libffi call failed for function ~S."
  59                     function-name))
  60     cif))
  61
  62 (defun free-libffi-cif (ptr)
  63   (foreign-free (foreign-slot-value ptr '(:struct ffi-cif) 'argument-types))
  64   (foreign-free ptr))
  65
  66 (defun translate-objects-ret (symbols function-arguments types return-type call-form)
  67   (translate-objects
  68    symbols
  69    function-arguments
  70    types
  71    return-type
  72    (if (or (eql return-type :void)
  73            (typep (parse-type return-type) 'translatable-foreign-type))
  74        call-form
  75        ;; built-in types won't be translated by
  76        ;; expand-from-foreign, we have to do it here
  77        `(mem-ref
  78          ,call-form
  79          ',(canonicalize-foreign-type return-type)))
  80    t))
  81
  82 (defun foreign-funcall-form/fsbv-with-libffi (function function-arguments symbols types
  83                                               return-type argument-types
  84                                               &optional pointerp (abi :default-abi))
  85   "A body of foreign-funcall calling the libffi function #'call (ffi_call)."
  86   (let ((argument-count (length argument-types)))
  87     `(with-foreign-objects ((argument-values :pointer ,argument-count)
  88                             ,@(unless (eql return-type :void)
  89                                 `((result ',return-type))))
  90        ,(translate-objects-ret
  91          symbols function-arguments types return-type
  92          ;; NOTE: We must delay the cif creation until the first call
  93          ;; because it's FOREIGN-ALLOC'd, i.e. it gets corrupted by an
  94          ;; image save/restore cycle. This way a lib will remain usable
  95          ;; through a save/restore cycle if the save happens before any
  96          ;; FFI calls will have been made, i.e. nothing is malloc'd yet.
  97          `(progn
  98             (loop
  99               :for arg :in (list ,@symbols)
 100               :for count :from 0
 101               :do (setf (mem-aref argument-values :pointer count) arg))
 102             (let* ((libffi-cif-cache (load-time-value (cons 'libffi-cif-cache nil)))
 103                    (libffi-cif (or (cdr libffi-cif-cache)
 104                                    (setf (cdr libffi-cif-cache)
 105                                          ;; FIXME ideally we should install a finalizer on the cons
 106                                          ;; that calls FREE-LIBFFI-CIF on the cif (when the function
 107                                          ;; gets redefined, and the cif becomes unreachable). but a
 108                                          ;; finite world is full of compromises... - attila
 109                                          (make-libffi-cif ,function ',return-type
 110                                                           ',argument-types ',abi)))))
 111               (libffi/call libffi-cif
 112                            ,(if pointerp
 113                                 function
 114                                 `(foreign-symbol-pointer ,function))
 115                            ,(if (eql return-type :void) '(null-pointer) 'result)
 116                            argument-values)
 117               ,(if (eql return-type :void)
 118                    '(values)
 119                    'result)))))))
 120
 121 (setf *foreign-structures-by-value* 'foreign-funcall-form/fsbv-with-libffi)
 122
 123 ;; DEPRECATED Its presence encourages the use of #+fsbv which may lead to the
 124 ;; situation where a fasl was produced by an image that has fsbv feature
 125 ;; and then ends up being loaded into an image later that has no fsbv support
 126 ;; loaded. Use explicit ASDF dependencies instead and assume the presence
 127 ;; of the feature accordingly.
 128 (pushnew :fsbv *features*)
 129
 130 ;; DEPRECATED This is here only for backwards compatibility until its fate is
 131 ;; decided. See the mailing list discussion for details.
 132 (defctype :sizet size-t)