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