src/cffi-mkcl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-mkcl.lisp --- MKCL backend for CFFI.
   4 ;;;
   5 ;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin
   6 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person
   9 ;;; obtaining a copy of this software and associated documentation
  10 ;;; files (the "Software"), to deal in the Software without
  11 ;;; restriction, including without limitation the rights to use, copy,
  12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  13 ;;; of the Software, and to permit persons to whom the Software is
  14 ;;; furnished to do so, subject to the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  26 ;;; DEALINGS IN THE SOFTWARE.
  27 ;;;
  28
  29 (in-package #:cffi-sys)
  30
  31 ;;;# Mis-features
  32
  33 (pushnew 'flat-namespace *features*)
  34
  35 ;;;# Symbol Case
  36
  37 (defun canonicalize-symbol-name-case (name)
  38   (declare (string name))
  39   (string-upcase name))
  40
  41 ;;;# Allocation
  42
  43 (defun %foreign-alloc (size)
  44   "Allocate SIZE bytes of foreign-addressable memory."
  45   (si:allocate-foreign-data :void size))
  46
  47 (defun foreign-free (ptr)
  48   "Free a pointer PTR allocated by FOREIGN-ALLOC."
  49   (si:free-foreign-data ptr)
  50   nil)
  51
  52 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  53   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  54 pointer in VAR is invalid beyond the dynamic extent of BODY, and
  55 may be stack-allocated if supported by the implementation.  If
  56 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
  57   (unless size-var
  58     (setf size-var (gensym "SIZE")))
  59   `(let* ((,size-var ,size)
  60           (,var (%foreign-alloc ,size-var)))
  61      (unwind-protect
  62           (progn ,@body)
  63        (foreign-free ,var))))
  64
  65 ;;;# Misc. Pointer Operations
  66
  67 (deftype foreign-pointer ()
  68   'si:foreign)
  69
  70 (defun null-pointer ()
  71   "Construct and return a null pointer."
  72   (si:make-foreign-null-pointer))
  73
  74 (defun null-pointer-p (ptr)
  75   "Return true if PTR is a null pointer."
  76   (si:null-pointer-p ptr))
  77
  78 (defun inc-pointer (ptr offset)
  79   "Return a pointer OFFSET bytes past PTR."
  80   (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
  81
  82 (defun pointerp (ptr)
  83   "Return true if PTR is a foreign pointer."
  84   ;;(typep ptr 'si:foreign)
  85   (si:foreignp ptr))
  86
  87 (defun pointer-eq (ptr1 ptr2)
  88   "Return true if PTR1 and PTR2 point to the same address."
  89   (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
  90
  91 (defun make-pointer (address)
  92   "Return a pointer pointing to ADDRESS."
  93   (ffi:make-pointer address :void))
  94
  95 (defun pointer-address (ptr)
  96   "Return the address pointed to by PTR."
  97   (ffi:pointer-address ptr))
  98
  99 ;;;# Shareable Vectors
 100 ;;;
 101 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 102 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 103 ;;; implementation can't do this.
 104
 105 (defun make-shareable-byte-vector (size)
 106   "Create a Lisp vector of SIZE bytes that can passed to
 107 WITH-POINTER-TO-VECTOR-DATA."
 108   (make-array size :element-type '(unsigned-byte 8)))
 109
 110 ;;; MKCL, built with the Boehm GC never moves allocated data, so this
 111 ;;; isn't nearly as hard to do.
 112 (defun %vector-address (vector)
 113   "Return the address of VECTOR's data."
 114   (check-type vector (vector (unsigned-byte 8)))
 115   #-mingw64
 116   (ffi:c-inline (vector) (object)
 117                 :unsigned-long
 118                 "(uintptr_t) #0->vector.self.b8"
 119                 :side-effects nil
 120                 :one-liner t)
 121   #+mingw64
 122   (ffi:c-inline (vector) (object)
 123                 :unsigned-long-long
 124                 "(uintptr_t) #0->vector.self.b8"
 125                 :side-effects nil
 126                 :one-liner t))
 127
 128 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 129   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 130   `(let ((,ptr-var (make-pointer (%vector-address ,vector))))
 131      ,@body))
 132
 133 ;;;# Dereferencing
 134
 135 (defun %mem-ref (ptr type &optional (offset 0))
 136   "Dereference an object of TYPE at OFFSET bytes from PTR."
 137   (let* ((type (cffi-type->mkcl-type type))
 138          (type-size (ffi:size-of-foreign-type type)))
 139     (si:foreign-ref-elt
 140      (si:foreign-recast ptr (+ offset type-size) :void) offset type)))
 141
 142 (defun %mem-set (value ptr type &optional (offset 0))
 143   "Set an object of TYPE at OFFSET bytes from PTR."
 144   (let* ((type (cffi-type->mkcl-type type))
 145          (type-size (ffi:size-of-foreign-type type)))
 146     (si:foreign-set-elt
 147      (si:foreign-recast ptr (+ offset type-size) :void)
 148      offset type value)))
 149
 150 ;;;# Type Operations
 151
 152 (defconstant +translation-table+
 153   '((:char               :byte               "char")
 154     (:unsigned-char      :unsigned-byte      "unsigned char")
 155     (:short              :short              "short")
 156     (:unsigned-short     :unsigned-short     "unsigned short")
 157     (:int                :int                "int")
 158     (:unsigned-int       :unsigned-int       "unsigned int")
 159     (:long               :long               "long")
 160     (:unsigned-long      :unsigned-long      "unsigned long")
 161     (:long-long          :long-long          "long long")
 162     (:unsigned-long-long :unsigned-long-long "unsigned long long")
 163     (:float              :float              "float")
 164     (:double             :double             "double")
 165     (:pointer            :pointer-void       "void*")
 166     (:void               :void               "void")))
 167
 168 (defun cffi-type->mkcl-type (type-keyword)
 169   "Convert a CFFI type keyword to an MKCL type keyword."
 170   (or (second (find type-keyword +translation-table+ :key #'first))
 171       (error "~S is not a valid CFFI type" type-keyword)))
 172
 173 (defun mkcl-type->c-type (type-keyword)
 174   "Convert a CFFI type keyword to an valid C type keyword."
 175   (or (third (find type-keyword +translation-table+ :key #'second))
 176       (error "~S is not a valid CFFI type" type-keyword)))
 177
 178 (defun %foreign-type-size (type-keyword)
 179   "Return the size in bytes of a foreign type."
 180   (nth-value 0 (ffi:size-of-foreign-type
 181                 (cffi-type->mkcl-type type-keyword))))
 182
 183 (defun %foreign-type-alignment (type-keyword)
 184   "Return the alignment in bytes of a foreign type."
 185   (nth-value 1 (ffi:size-of-foreign-type
 186                 (cffi-type->mkcl-type type-keyword))))
 187
 188 ;;;# Calling Foreign Functions
 189
 190 #|
 191 (defconstant +mkcl-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")
 192 |#
 193
 194 (defun produce-function-pointer-call (pointer types values return-type)
 195 #|
 196   (if (stringp pointer)
 197       (produce-function-pointer-call
 198        `(%foreign-symbol-pointer ,pointer nil) types values return-type)
 199       `(ffi:c-inline
 200         ,(list* pointer values)
 201         ,(list* :pointer-void types) ,return-type
 202         ,(with-output-to-string (s)
 203            (let ((types (mapcar #'mkcl-type->c-type types)))
 204              ;; On AMD64, the following code only works with the extra
 205              ;; argument ",...". If this is not present, functions
 206              ;; like sprintf do not work
 207              (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
 208                      (mkcl-type->c-type return-type) types
 209                      (subseq +mkcl-inline-codes+ 3
 210                              (max 3 (+ 2 (* (length values) 3)))))))
 211         :one-liner t :side-effects t))
 212 |#
 213   ;; The version here below is definitely not as efficient as the one above
 214   ;; but it has the great vertue of working in all cases, (contrary to the
 215   ;; silent and unsafe limitations of the one above). JCB
 216   ;; I should re-optimize this one day, when I get time... JCB
 217   (progn
 218     (when (stringp pointer)
 219       (setf pointer `(%foreign-symbol-pointer ,pointer nil)))
 220     `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))))
 221
 222
 223 (defun foreign-funcall-parse-args (args)
 224   "Return three values, lists of arg types, values, and result type."
 225   (let ((return-type :void))
 226     (loop for (type arg) on args by #'cddr
 227           if arg collect (cffi-type->mkcl-type type) into types
 228           and collect arg into values
 229           else do (setf return-type (cffi-type->mkcl-type type))
 230           finally (return (values types values return-type)))))
 231
 232 (defmacro %foreign-funcall (name args &key library convention)
 233   "Call a foreign function."
 234   (declare (ignore library convention))
 235   (multiple-value-bind (types values return-type)
 236       (foreign-funcall-parse-args args)
 237     (produce-function-pointer-call name types values return-type)))
 238
 239 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 240   "Funcall a pointer to a foreign function."
 241   (declare (ignore convention))
 242   (multiple-value-bind (types values return-type)
 243       (foreign-funcall-parse-args args)
 244     (produce-function-pointer-call ptr types values return-type)))
 245
 246 ;;;# Foreign Libraries
 247
 248 (defun %load-foreign-library (name path)
 249   "Load a foreign library."
 250   (declare (ignore name))
 251   (handler-case (si:load-foreign-module path)
 252     (file-error ()
 253       (error "file error while trying to load `~A'" path))))
 254
 255 (defun %close-foreign-library (handle)
 256   ;;(declare (ignore handle))
 257   ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.")
 258   (si:unload-foreign-module handle))
 259
 260 (defun native-namestring (pathname)
 261   (namestring pathname))
 262
 263 ;;;# Callbacks
 264
 265 (defvar *callbacks* (make-hash-table))
 266
 267 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
 268 ;;; internal callback for NAME.
 269 (eval-when (:compile-toplevel :load-toplevel :execute)
 270   (defun intern-callback (name)
 271     (intern (format nil "~A::~A"
 272                     (if-let (package (symbol-package name))
 273                       (package-name package)
 274                       "#")
 275                     (symbol-name name))
 276             '#:cffi-callbacks)))
 277
 278 (defmacro %defcallback (name rettype arg-names arg-types body
 279                         &key convention)
 280   (declare (ignore convention))
 281   (let ((cb-name (intern-callback name)))
 282     `(progn
 283        (ffi:defcallback (,cb-name :cdecl)
 284                         ,(cffi-type->mkcl-type rettype)
 285                         ,(mapcar #'list arg-names
 286                                  (mapcar #'cffi-type->mkcl-type arg-types))
 287                         ;;(block ,cb-name ,@body)
 288                         (block ,cb-name ,body))
 289        (setf (gethash ',name *callbacks*) ',cb-name))))
 290
 291 (defun %callback (name)
 292   (multiple-value-bind (symbol winp)
 293       (gethash name *callbacks*)
 294     (unless winp
 295       (error "Undefined callback: ~S" name))
 296     (ffi:callback symbol)))
 297
 298 ;;;# Foreign Globals
 299
 300 (defun %foreign-symbol-pointer (name library)
 301   "Returns a pointer to a foreign symbol NAME."
 302   (declare (ignore library))
 303   (values (ignore-errors (si:find-foreign-symbol name :default :pointer-void 0))))
 304