src/cffi-clisp.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;; Copyright (C) 2005-2006, Joerg Hoehle  <hoehle@users.sourceforge.net>
   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 (eval-when (:compile-toplevel :load-toplevel :execute)
  32   (unless (find-package :ffi)
  33     (error "CFFI requires CLISP compiled with dynamic FFI support.")))
  34
  35 ;;;# Symbol Case
  36
  37 (defun canonicalize-symbol-name-case (name)
  38   (declare (string name))
  39   (string-upcase name))
  40
  41 ;;;# Built-In Foreign Types
  42
  43 (defun convert-foreign-type (type)
  44   "Convert a CFFI built-in type keyword to a CLisp FFI type."
  45   (ecase type
  46     (:char 'ffi:char)
  47     (:unsigned-char 'ffi:uchar)
  48     (:short 'ffi:short)
  49     (:unsigned-short 'ffi:ushort)
  50     (:int 'ffi:int)
  51     (:unsigned-int 'ffi:uint)
  52     (:long 'ffi:long)
  53     (:unsigned-long 'ffi:ulong)
  54     (:long-long 'ffi:sint64)
  55     (:unsigned-long-long 'ffi:uint64)
  56     (:float 'ffi:single-float)
  57     (:double 'ffi:double-float)
  58     ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
  59     ;; we have a workaround in the pointer operations...
  60     (:pointer 'ffi:c-pointer)
  61     (:void nil)))
  62
  63 (defun %foreign-type-size (type)
  64   "Return the size in bytes of objects having foreign type TYPE."
  65   (nth-value 0 (ffi:sizeof (convert-foreign-type type))))
  66
  67 ;; Remind me to buy a beer for whoever made getting the alignment
  68 ;; of foreign types part of the public interface in CLisp. :-)
  69 (defun %foreign-type-alignment (type)
  70   "Return the structure alignment in bytes of foreign TYPE."
  71   #+(and darwin ppc)
  72   (case type
  73     ((:double :long-long :unsigned-long-long)
  74      (return-from %foreign-type-alignment 8)))
  75   ;; Override not necessary for the remaining types...
  76   (nth-value 1 (ffi:sizeof (convert-foreign-type type))))
  77
  78 ;;;# Basic Pointer Operations
  79
  80 (deftype foreign-pointer ()
  81   'ffi:foreign-address)
  82
  83 (defun pointerp (ptr)
  84   "Return true if PTR is a foreign pointer."
  85   (typep ptr 'ffi:foreign-address))
  86
  87 (defun pointer-eq (ptr1 ptr2)
  88   "Return true if PTR1 and PTR2 point to the same address."
  89   (eql (ffi:foreign-address-unsigned ptr1)
  90        (ffi:foreign-address-unsigned ptr2)))
  91
  92 (defun null-pointer ()
  93   "Return a null foreign pointer."
  94   (ffi:unsigned-foreign-address 0))
  95
  96 (defun null-pointer-p (ptr)
  97   "Return true if PTR is a null foreign pointer."
  98   (zerop (ffi:foreign-address-unsigned ptr)))
  99
 100 (defun inc-pointer (ptr offset)
 101   "Return a pointer pointing OFFSET bytes past PTR."
 102   (ffi:unsigned-foreign-address
 103    (+ offset (ffi:foreign-address-unsigned ptr))))
 104
 105 (defun make-pointer (address)
 106   "Return a pointer pointing to ADDRESS."
 107   (ffi:unsigned-foreign-address address))
 108
 109 (defun pointer-address (ptr)
 110   "Return the address pointed to by PTR."
 111   (ffi:foreign-address-unsigned ptr))
 112
 113 ;;;# Foreign Memory Allocation
 114
 115 (defun %foreign-alloc (size)
 116   "Allocate SIZE bytes of foreign-addressable memory and return a
 117 pointer to the allocated block.  An implementation-specific error
 118 is signalled if the memory cannot be allocated."
 119   (ffi:foreign-address
 120    (ffi:allocate-shallow 'ffi:uint8 :count (if (zerop size) 1 size))))
 121
 122 (defun foreign-free (ptr)
 123   "Free a pointer PTR allocated by FOREIGN-ALLOC.  The results
 124 are undefined if PTR is used after being freed."
 125   (ffi:foreign-free ptr))
 126
 127 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 128   "Bind VAR to a pointer to SIZE bytes of foreign-addressable
 129 memory during BODY.  Both PTR and the memory block pointed to
 130 have dynamic extent and may be stack allocated if supported by
 131 the implementation.  If SIZE-VAR is supplied, it will be bound to
 132 SIZE during BODY."
 133   (unless size-var
 134     (setf size-var (gensym "SIZE")))
 135   (let ((obj-var (gensym)))
 136     `(let ((,size-var ,size))
 137        (ffi:with-foreign-object
 138            (,obj-var `(ffi:c-array ffi:uint8 ,,size-var))
 139          (let ((,var (ffi:foreign-address ,obj-var)))
 140            ,@body)))))
 141
 142 ;;;# Memory Access
 143
 144 ;;; %MEM-REF and its compiler macro work around CLISP's FFI:C-POINTER
 145 ;;; type and convert NILs back to null pointers.
 146 (defun %mem-ref (ptr type &optional (offset 0))
 147   "Dereference a pointer OFFSET bytes from PTR to an object of
 148 built-in foreign TYPE.  Returns the object as a foreign pointer
 149 or Lisp number."
 150   (let ((value (ffi:memory-as ptr (convert-foreign-type type) offset)))
 151     (if (eq type :pointer)
 152         (or value (null-pointer))
 153         value)))
 154
 155 (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
 156   "Compiler macro to open-code when TYPE is constant."
 157   (if (constantp type)
 158       (let* ((ftype (convert-foreign-type (eval type)))
 159              (form `(ffi:memory-as ,ptr ',ftype ,offset)))
 160         (if (eq type :pointer)
 161             `(or ,form (null-pointer))
 162             form))
 163       form))
 164
 165 (defun %mem-set (value ptr type &optional (offset 0))
 166   "Set a pointer OFFSET bytes from PTR to an object of built-in
 167 foreign TYPE to VALUE."
 168   (setf (ffi:memory-as ptr (convert-foreign-type type) offset) value))
 169
 170 (define-compiler-macro %mem-set
 171     (&whole form value ptr type &optional (offset 0))
 172   (if (constantp type)
 173       ;; (setf (ffi:memory-as) value) is exported, but not so nice
 174       ;; w.r.t. the left to right evaluation rule
 175       `(ffi::write-memory-as
 176         ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
 177       form))
 178
 179 ;;;# Shareable Vectors
 180 ;;;
 181 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 182 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 183 ;;; implementation can't do this.
 184
 185 (declaim (inline make-shareable-byte-vector))
 186 (defun make-shareable-byte-vector (size)
 187   "Create a Lisp vector of SIZE bytes can passed to
 188 WITH-POINTER-TO-VECTOR-DATA."
 189   (make-array size :element-type '(unsigned-byte 8)))
 190
 191 (deftype shareable-byte-vector ()
 192   `(vector (unsigned-byte 8)))
 193
 194 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 195   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 196   (with-unique-names (vector-var size-var)
 197     `(let ((,vector-var ,vector))
 198        (check-type ,vector-var shareable-byte-vector)
 199        (with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var)
 200          ;; copy-in
 201          (loop for i below ,size-var do
 202                (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i))
 203          (unwind-protect (progn ,@body)
 204            ;; copy-out
 205            (loop for i below ,size-var do
 206                  (setf (aref ,vector-var i)
 207                        (%mem-ref ,ptr-var :unsigned-char i))))))))
 208
 209 ;;;# Foreign Function Calling
 210
 211 (defun parse-foreign-funcall-args (args)
 212   "Return three values, a list of CLISP FFI types, a list of
 213 values to pass to the function, and the CLISP FFI return type."
 214   (let ((return-type nil))
 215     (loop for (type arg) on args by #'cddr
 216           if arg collect (list (gensym) (convert-foreign-type type)) into types
 217           and collect arg into fargs
 218           else do (setf return-type (convert-foreign-type type))
 219           finally (return (values types fargs return-type)))))
 220
 221 (defun convert-calling-convention (convention)
 222   (ecase convention
 223     (:stdcall :stdc-stdcall)
 224     (:cdecl :stdc)))
 225
 226 (defun c-function-type (arg-types rettype convention)
 227   "Generate the apropriate CLISP foreign type specification. Also
 228 takes care of converting the calling convention names."
 229   `(ffi:c-function (:arguments ,@arg-types)
 230                    (:return-type ,rettype)
 231                    (:language ,(convert-calling-convention convention))))
 232
 233 ;;; Quick hack around the fact that the CFFI package is not yet
 234 ;;; defined when this file is loaded.  I suppose we could arrange for
 235 ;;; the CFFI package to be defined a bit earlier, though.
 236 (defun library-handle-form (name)
 237   (flet ((find-cffi-symbol (symbol)
 238            (find-symbol (symbol-name symbol) '#:cffi)))
 239     `(,(find-cffi-symbol '#:foreign-library-handle)
 240        (,(find-cffi-symbol '#:get-foreign-library) ',name))))
 241
 242 (eval-when (:compile-toplevel :load-toplevel :execute)
 243   ;; version 2.40 (CVS 2006-09-03, to be more precise) added a
 244   ;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION.
 245   (defun post-2.40-ffi-interface-p ()
 246     (let ((f-l-f (find-symbol (string '#:foreign-library-function) '#:ffi)))
 247       (if (and f-l-f (= (length (ext:arglist f-l-f)) 5))
 248           '(:and)
 249           '(:or))))
 250   ;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE
 251   ;; were deprecated in 2.41 and removed in 2.45.
 252   (defun post-2.45-ffi-interface-p ()
 253     (if (find-symbol (string '#:foreign-library-function) '#:ffi)
 254         '(:or)
 255         '(:and))))
 256
 257 #+#.(cffi-sys::post-2.45-ffi-interface-p)
 258 (defun %foreign-funcall-aux (name type library)
 259   `(ffi::find-foreign-function ,name ,type nil ,library nil nil))
 260
 261 #-#.(cffi-sys::post-2.45-ffi-interface-p)
 262 (defun %foreign-funcall-aux (name type library)
 263   `(ffi::foreign-library-function
 264     ,name ,library nil
 265     #+#.(cffi-sys::post-2.40-ffi-interface-p)
 266     nil
 267     ,type))
 268
 269 (defmacro %foreign-funcall (name args &key library convention)
 270   "Invoke a foreign function called NAME, taking pairs of
 271 foreign-type/value pairs from ARGS.  If a single element is left
 272 over at the end of ARGS, it specifies the foreign return type of
 273 the function call."
 274   (multiple-value-bind (types fargs rettype)
 275       (parse-foreign-funcall-args args)
 276     (let* ((fn (%foreign-funcall-aux
 277                 name
 278                 `(ffi:parse-c-type
 279                   ',(c-function-type types rettype convention))
 280                 (if (eq library :default)
 281                     :default
 282                     (library-handle-form library))))
 283           (form `(funcall
 284                   (load-time-value
 285                    (handler-case ,fn
 286                      (error (err)
 287                        (warn "~A" err))))
 288                   ,@fargs)))
 289       (if (eq rettype 'ffi:c-pointer)
 290           `(or ,form (null-pointer))
 291           form))))
 292
 293 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 294   "Similar to %foreign-funcall but takes a pointer instead of a string."
 295   (multiple-value-bind (types fargs rettype)
 296       (parse-foreign-funcall-args args)
 297     `(funcall (ffi:foreign-function
 298                ,ptr (load-time-value
 299                      (ffi:parse-c-type ',(c-function-type
 300                                           types rettype convention))))
 301               ,@fargs)))
 302
 303 ;;;# Callbacks
 304
 305 ;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK
 306 ;;; macro.  The symbol naming the callback is the key, and the value
 307 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
 308 ;;; the callback, and a saved pointer that should not persist across
 309 ;;; saved images.
 310 (defvar *callbacks* (make-hash-table))
 311
 312 ;;; Return a CLISP FFI function type for a CFFI callback function
 313 ;;; given a return type and list of argument names and types.
 314 (eval-when (:compile-toplevel :load-toplevel :execute)
 315   (defun callback-type (rettype arg-names arg-types convention)
 316     (ffi:parse-c-type
 317      `(ffi:c-function
 318        (:arguments ,@(mapcar (lambda (sym type)
 319                                (list sym (convert-foreign-type type)))
 320                              arg-names arg-types))
 321        (:return-type ,(convert-foreign-type rettype))
 322        (:language ,(convert-calling-convention convention))))))
 323
 324 ;;; Register and create a callback function.
 325 (defun register-callback (name function parsed-type)
 326   (setf (gethash name *callbacks*)
 327         (list function parsed-type
 328               (ffi:with-foreign-object (ptr 'ffi:c-pointer)
 329                 ;; Create callback by converting Lisp function to foreign
 330                 (setf (ffi:memory-as ptr parsed-type) function)
 331                 (ffi:foreign-value ptr)))))
 332
 333 ;;; Restore all saved callback pointers when restarting the Lisp
 334 ;;; image.  This is pushed onto CUSTOM:*INIT-HOOKS*.
 335 ;;; Needs clisp > 2.35, bugfix 2005-09-29
 336 (defun restore-callback-pointers ()
 337   (maphash
 338    (lambda (name list)
 339      (register-callback name (first list) (second list)))
 340    *callbacks*))
 341
 342 ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
 343 ;;; when an image is restarted.
 344 (eval-when (:load-toplevel :execute)
 345   (pushnew 'restore-callback-pointers custom:*init-hooks*))
 346
 347 ;;; Define a callback function NAME to run BODY with arguments
 348 ;;; ARG-NAMES translated according to ARG-TYPES and the return type
 349 ;;; translated according to RETTYPE.  Obtain a pointer that can be
 350 ;;; passed to C code for this callback by calling %CALLBACK.
 351 (defmacro %defcallback (name rettype arg-names arg-types body
 352                         &key convention)
 353   `(register-callback
 354     ',name
 355     (lambda ,arg-names
 356       ;; Work around CLISP's FFI:C-POINTER type and convert NIL values
 357       ;; back into a null pointers.
 358       (let (,@(loop for name in arg-names
 359                     and type in arg-types
 360                     when (eq type :pointer)
 361                     collect `(,name (or ,name (null-pointer)))))
 362         ,body))
 363     ,(callback-type rettype arg-names arg-types convention)))
 364
 365 ;;; Look up the name of a callback and return a pointer that can be
 366 ;;; passed to a C function.  Signals an error if no callback is
 367 ;;; defined called NAME.
 368 (defun %callback (name)
 369   (multiple-value-bind (list winp) (gethash name *callbacks*)
 370     (unless winp
 371       (error "Undefined callback: ~S" name))
 372     (third list)))
 373
 374 ;;;# Loading and Closing Foreign Libraries
 375
 376 (defun %load-foreign-library (name path)
 377   "Load a foreign library from PATH."
 378   (declare (ignore name))
 379   #+#.(cffi-sys::post-2.45-ffi-interface-p)
 380   (ffi:open-foreign-library path)
 381   #-#.(cffi-sys::post-2.45-ffi-interface-p)
 382   (ffi::foreign-library path))
 383
 384 (defun %close-foreign-library (handle)
 385   "Close a foreign library."
 386   (ffi:close-foreign-library handle))
 387
 388 (defun native-namestring (pathname)
 389   (namestring pathname))
 390
 391 ;;;# Foreign Globals
 392
 393 (defun %foreign-symbol-pointer (name library)
 394   "Returns a pointer to a foreign symbol NAME."
 395   (prog1 (ignore-errors
 396            (ffi:foreign-address
 397             #+#.(cffi-sys::post-2.45-ffi-interface-p)
 398             (ffi::find-foreign-variable name nil library nil nil)
 399             #-#.(cffi-sys::post-2.45-ffi-interface-p)
 400             (ffi::foreign-library-variable name library nil nil)))))