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 ;;;# Administrivia
  30
  31 (defpackage #:cffi-sys
  32   (:use #:common-lisp #:alexandria)
  33   (:export
  34    #:canonicalize-symbol-name-case
  35    #:foreign-pointer
  36    #:pointerp
  37    #:pointer-eq
  38    #:null-pointer
  39    #:null-pointer-p
  40    #:inc-pointer
  41    #:make-pointer
  42    #:pointer-address
  43    #:%foreign-alloc
  44    #:foreign-free
  45    #:with-foreign-pointer
  46    #:%foreign-funcall
  47    #:%foreign-funcall-pointer
  48    #:%foreign-type-alignment
  49    #:%foreign-type-size
  50    #:%load-foreign-library
  51    #:%close-foreign-library
  52    #:native-namestring
  53    #:%mem-ref
  54    #:%mem-set
  55    #:make-shareable-byte-vector
  56    #:with-pointer-to-vector-data
  57    #:%foreign-symbol-pointer
  58    #:%defcallback
  59    #:%callback))
  60
  61 (in-package #:cffi-sys)
  62
  63 ;;;# Mis-features
  64
  65 (pushnew 'flat-namespace *features*)
  66
  67 ;;;# Symbol Case
  68
  69 (defun canonicalize-symbol-name-case (name)
  70   (declare (string name))
  71   (string-upcase name))
  72
  73 ;;;# Allocation
  74
  75 (defun %foreign-alloc (size)
  76   "Allocate SIZE bytes of foreign-addressable memory."
  77   (si:allocate-foreign-data :void size))
  78
  79 (defun foreign-free (ptr)
  80   "Free a pointer PTR allocated by FOREIGN-ALLOC."
  81   (si:free-foreign-data ptr)
  82   nil)
  83
  84 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  85   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  86 pointer in VAR is invalid beyond the dynamic extent of BODY, and
  87 may be stack-allocated if supported by the implementation.  If
  88 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
  89   (unless size-var
  90     (setf size-var (gensym "SIZE")))
  91   `(let* ((,size-var ,size)
  92           (,var (%foreign-alloc ,size-var)))
  93      (unwind-protect
  94           (progn ,@body)
  95        (foreign-free ,var))))
  96
  97 ;;;# Misc. Pointer Operations
  98
  99 (deftype foreign-pointer ()
 100   'si:foreign)
 101
 102 (defun null-pointer ()
 103   "Construct and return a null pointer."
 104   (si:make-foreign-null-pointer))
 105
 106 (defun null-pointer-p (ptr)
 107   "Return true if PTR is a null pointer."
 108   (si:null-pointer-p ptr))
 109
 110 (defun inc-pointer (ptr offset)
 111   "Return a pointer OFFSET bytes past PTR."
 112   (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
 113
 114 (defun pointerp (ptr)
 115   "Return true if PTR is a foreign pointer."
 116   ;;(typep ptr 'si:foreign)
 117   (si:foreignp ptr))
 118
 119 (defun pointer-eq (ptr1 ptr2)
 120   "Return true if PTR1 and PTR2 point to the same address."
 121   (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
 122
 123 (defun make-pointer (address)
 124   "Return a pointer pointing to ADDRESS."
 125   (ffi:make-pointer address :void))
 126
 127 (defun pointer-address (ptr)
 128   "Return the address pointed to by PTR."
 129   (ffi:pointer-address ptr))
 130
 131 ;;;# Shareable Vectors
 132 ;;;
 133 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 134 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 135 ;;; implementation can't do this.
 136
 137 (defun make-shareable-byte-vector (size)
 138   "Create a Lisp vector of SIZE bytes that can passed to
 139 WITH-POINTER-TO-VECTOR-DATA."
 140   (make-array size :element-type '(unsigned-byte 8)))
 141
 142 ;;; MKCL, built with the Boehm GC never moves allocated data, so this
 143 ;;; isn't nearly as hard to do.
 144 (defun %vector-address (vector)
 145   "Return the address of VECTOR's data."
 146   (check-type vector (vector (unsigned-byte 8)))
 147   #-mingw64
 148   (ffi:c-inline (vector) (object)
 149                 :unsigned-long
 150                 "(uintptr_t) #0->vector.self.b8"
 151                 :side-effects nil
 152                 :one-liner t)
 153   #+mingw64
 154   (ffi:c-inline (vector) (object)
 155                 :unsigned-long-long
 156                 "(uintptr_t) #0->vector.self.b8"
 157                 :side-effects nil
 158                 :one-liner t))
 159
 160 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 161   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 162   `(let ((,ptr-var (make-pointer (%vector-address ,vector))))
 163      ,@body))
 164
 165 ;;;# Dereferencing
 166
 167 (defun %mem-ref (ptr type &optional (offset 0))
 168   "Dereference an object of TYPE at OFFSET bytes from PTR."
 169   (let* ((type (cffi-type->mkcl-type type))
 170          (type-size (ffi:size-of-foreign-type type)))
 171     (si:foreign-ref-elt
 172      (si:foreign-recast ptr (+ offset type-size) :void) offset type)))
 173
 174 (defun %mem-set (value ptr type &optional (offset 0))
 175   "Set an object of TYPE at OFFSET bytes from PTR."
 176   (let* ((type (cffi-type->mkcl-type type))
 177          (type-size (ffi:size-of-foreign-type type)))
 178     (si:foreign-set-elt
 179      (si:foreign-recast ptr (+ offset type-size) :void)
 180      offset type value)))
 181
 182 ;;;# Type Operations
 183
 184 (defconstant +translation-table+
 185   '((:char               :byte               "char")
 186     (:unsigned-char      :unsigned-byte      "unsigned char")
 187     (:short              :short              "short")
 188     (:unsigned-short     :unsigned-short     "unsigned short")
 189     (:int                :int                "int")
 190     (:unsigned-int       :unsigned-int       "unsigned int")
 191     (:long               :long               "long")
 192     (:unsigned-long      :unsigned-long      "unsigned long")
 193     (:long-long          :long-long          "long long")
 194     (:unsigned-long-long :unsigned-long-long "unsigned long long")
 195     (:float              :float              "float")
 196     (:double             :double             "double")
 197     (:pointer            :pointer-void       "void*")
 198     (:void               :void               "void")))
 199
 200 (defun cffi-type->mkcl-type (type-keyword)
 201   "Convert a CFFI type keyword to an MKCL type keyword."
 202   (or (second (find type-keyword +translation-table+ :key #'first))
 203       (error "~S is not a valid CFFI type" type-keyword)))
 204
 205 (defun mkcl-type->c-type (type-keyword)
 206   "Convert a CFFI type keyword to an valid C type keyword."
 207   (or (third (find type-keyword +translation-table+ :key #'second))
 208       (error "~S is not a valid CFFI type" type-keyword)))
 209
 210 (defun %foreign-type-size (type-keyword)
 211   "Return the size in bytes of a foreign type."
 212   (nth-value 0 (ffi:size-of-foreign-type
 213                 (cffi-type->mkcl-type type-keyword))))
 214
 215 (defun %foreign-type-alignment (type-keyword)
 216   "Return the alignment in bytes of a foreign type."
 217   (nth-value 1 (ffi:size-of-foreign-type
 218                 (cffi-type->mkcl-type type-keyword))))
 219
 220 ;;;# Calling Foreign Functions
 221
 222 #|
 223 (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")
 224 |#
 225
 226 (defun produce-function-pointer-call (pointer types values return-type)
 227 #|
 228   (if (stringp pointer)
 229       (produce-function-pointer-call
 230        `(%foreign-symbol-pointer ,pointer nil) types values return-type)
 231       `(ffi:c-inline
 232         ,(list* pointer values)
 233         ,(list* :pointer-void types) ,return-type
 234         ,(with-output-to-string (s)
 235            (let ((types (mapcar #'mkcl-type->c-type types)))
 236              ;; On AMD64, the following code only works with the extra
 237              ;; argument ",...". If this is not present, functions
 238              ;; like sprintf do not work
 239              (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
 240                      (mkcl-type->c-type return-type) types
 241                      (subseq +mkcl-inline-codes+ 3
 242                              (max 3 (+ 2 (* (length values) 3)))))))
 243         :one-liner t :side-effects t))
 244 |#
 245   ;; The version here below is definitely not as efficient as the one above
 246   ;; but it has the great vertue of working in all cases, (contrary to the
 247   ;; silent and unsafe limitations of the one above). JCB
 248   ;; I should re-optimize this one day, when I get time... JCB
 249   (progn
 250     (when (stringp pointer)
 251       (setf pointer `(%foreign-symbol-pointer ,pointer nil)))
 252     `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))))
 253
 254
 255 (defun foreign-funcall-parse-args (args)
 256   "Return three values, lists of arg types, values, and result type."
 257   (let ((return-type :void))
 258     (loop for (type arg) on args by #'cddr
 259           if arg collect (cffi-type->mkcl-type type) into types
 260           and collect arg into values
 261           else do (setf return-type (cffi-type->mkcl-type type))
 262           finally (return (values types values return-type)))))
 263
 264 (defmacro %foreign-funcall (name args &key library convention)
 265   "Call a foreign function."
 266   (declare (ignore library convention))
 267   (multiple-value-bind (types values return-type)
 268       (foreign-funcall-parse-args args)
 269     (produce-function-pointer-call name types values return-type)))
 270
 271 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 272   "Funcall a pointer to a foreign function."
 273   (declare (ignore convention))
 274   (multiple-value-bind (types values return-type)
 275       (foreign-funcall-parse-args args)
 276     (produce-function-pointer-call ptr types values return-type)))
 277
 278 ;;;# Foreign Libraries
 279
 280 (defun %load-foreign-library (name path)
 281   "Load a foreign library."
 282   (declare (ignore name))
 283   (handler-case (si:load-foreign-module path)
 284     (file-error ()
 285       (error "file error while trying to load `~A'" path))))
 286
 287 (defun %close-foreign-library (handle)
 288   ;;(declare (ignore handle))
 289   ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.")
 290   (si:unload-foreign-module handle))
 291
 292 (defun native-namestring (pathname)
 293   (namestring pathname))
 294
 295 ;;;# Callbacks
 296
 297 ;;; Create a package to contain the symbols for callback functions.
 298 ;;; We want to redefine callbacks with the same symbol so the internal
 299 ;;; data structures are reused.
 300 (defpackage #:cffi-callbacks
 301   (:use))
 302
 303 (defvar *callbacks* (make-hash-table))
 304
 305 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
 306 ;;; internal callback for NAME.
 307 (eval-when (:compile-toplevel :load-toplevel :execute)
 308   (defun intern-callback (name)
 309     (intern (format nil "~A::~A"
 310                     (if-let (package (symbol-package name))
 311                       (package-name package)
 312                       "#")
 313                     (symbol-name name))
 314             '#:cffi-callbacks)))
 315
 316 (defmacro %defcallback (name rettype arg-names arg-types body
 317                         &key convention)
 318   (declare (ignore convention))
 319   (let ((cb-name (intern-callback name)))
 320     `(progn
 321        (ffi:defcallback (,cb-name :cdecl)
 322                         ,(cffi-type->mkcl-type rettype)
 323                         ,(mapcar #'list arg-names
 324                                  (mapcar #'cffi-type->mkcl-type arg-types))
 325                         ;;(block ,cb-name ,@body)
 326                         (block ,cb-name ,body))
 327        (setf (gethash ',name *callbacks*) ',cb-name))))
 328
 329 (defun %callback (name)
 330   (multiple-value-bind (symbol winp)
 331       (gethash name *callbacks*)
 332     (unless winp
 333       (error "Undefined callback: ~S" name))
 334     (ffi:callback symbol)))
 335
 336 ;;;# Foreign Globals
 337
 338 (defun %foreign-symbol-pointer (name library)
 339   "Returns a pointer to a foreign symbol NAME."
 340   (declare (ignore library))
 341   (values (ignore-errors (si:find-foreign-symbol name :default :pointer-void 0))))
 342