external/cffi.darcs/src/cffi-allegro.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
   4 ;;;
   5 ;;; Copyright (C) 2005-2007, Luis Oliveira  <loliveira(@)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 ;;;# Administrivia
  29
  30 (defpackage #:cffi-sys
  31   (:use #:common-lisp #:cffi-utils)
  32   (:export
  33    #:canonicalize-symbol-name-case
  34    #:foreign-pointer
  35    #:pointerp
  36    #:pointer-eq
  37    #:null-pointer
  38    #:null-pointer-p
  39    #:inc-pointer
  40    #:make-pointer
  41    #:pointer-address
  42    #:%foreign-alloc
  43    #:foreign-free
  44    #:with-foreign-pointer
  45    #:%foreign-funcall
  46    #:%foreign-funcall-pointer
  47    #:%foreign-type-alignment
  48    #:%foreign-type-size
  49    #:%load-foreign-library
  50    #:%close-foreign-library
  51    #:native-namestring
  52    #:%mem-ref
  53    #:%mem-set
  54    ;#:make-shareable-byte-vector
  55    ;#:with-pointer-to-vector-data
  56    #:%foreign-symbol-pointer
  57    #:defcfun-helper-forms
  58    #:%defcallback
  59    #:%callback))
  60
  61 (in-package #:cffi-sys)
  62
  63 ;;;# Features
  64
  65 (eval-when (:compile-toplevel :load-toplevel :execute)
  66   (mapc (lambda (feature) (pushnew feature *features*))
  67         '(;; Backend mis-features.
  68           cffi-features:no-long-long
  69           cffi-features:flat-namespace
  70           ;; OS/CPU features.
  71           #+macosx     cffi-features:darwin
  72           #+unix       cffi-features:unix
  73           #+mswindows  cffi-features:windows
  74           #+powerpc    cffi-features:ppc32
  75           #+x86        cffi-features:x86
  76           #+x86-64     cffi-features:x86-64
  77           )))
  78
  79 ;;; Symbol case.
  80
  81 (defun canonicalize-symbol-name-case (name)
  82   (declare (string name))
  83   (if (eq excl:*current-case-mode* :case-sensitive-lower)
  84       (string-downcase name)
  85       (string-upcase name)))
  86
  87 ;;;# Basic Pointer Operations
  88
  89 (deftype foreign-pointer ()
  90   'ff:foreign-address)
  91
  92 (defun pointerp (ptr)
  93   "Return true if PTR is a foreign pointer."
  94   (ff:foreign-address-p ptr))
  95
  96 (defun pointer-eq (ptr1 ptr2)
  97   "Return true if PTR1 and PTR2 point to the same address."
  98   (eql ptr1 ptr2))
  99
 100 (defun null-pointer ()
 101   "Return a null pointer."
 102   0)
 103
 104 (defun null-pointer-p (ptr)
 105   "Return true if PTR is a null pointer."
 106   (zerop ptr))
 107
 108 (defun inc-pointer (ptr offset)
 109   "Return a pointer pointing OFFSET bytes past PTR."
 110   (+ ptr offset))
 111
 112 (defun make-pointer (address)
 113   "Return a pointer pointing to ADDRESS."
 114   (check-type address ff:foreign-address)
 115   address)
 116
 117 (defun pointer-address (ptr)
 118   "Return the address pointed to by PTR."
 119   (check-type ptr ff:foreign-address)
 120   ptr)
 121
 122 ;;;# Allocation
 123 ;;;
 124 ;;; Functions and macros for allocating foreign memory on the stack
 125 ;;; and on the heap.  The main CFFI package defines macros that wrap
 126 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
 127 ;;; when the memory has dynamic extent.
 128
 129 (defun %foreign-alloc (size)
 130   "Allocate SIZE bytes on the heap and return a pointer."
 131   (ff:allocate-fobject :char :c size))
 132
 133 (defun foreign-free (ptr)
 134   "Free a PTR allocated by FOREIGN-ALLOC."
 135   (ff:free-fobject ptr))
 136
 137 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 138   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
 139 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 140 may be stack-allocated if supported by the implementation.  If
 141 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 142   (unless size-var
 143     (setf size-var (gensym "SIZE")))
 144    #+(version>= 8 1)
 145    (cond ((and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*))
 146           ;; stack allocation pattern
 147           `(let ((,size-var ,size))
 148              (declare (ignorable ,size-var))
 149              (ff:with-stack-fobject (,var '(:array :char ,size))
 150                (let ((,var (ff:fslot-address ,var)))
 151                  ;; (excl::stack-allocated-p var) => T
 152                  ,@body))))
 153          (t
 154           ;; amalloc + free pattern
 155           `(let ((,size-var ,size))
 156              (declare (ignorable ,size-var))
 157              (ff:with-stack-fobject (,var :char :allocation :c :size ,size-var)
 158                (unwind-protect
 159                     (progn ,@body)
 160                  (ff:free-fobject ,var))))))
 161    #-(version>= 8 1)
 162    `(let ((,size-var ,size))
 163       (declare (ignorable ,size-var))
 164       (ff:with-stack-fobject (,var :char :c ,size-var)
 165         ,@body)))
 166
 167 ;;;# Shareable Vectors
 168 ;;;
 169 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 170 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 171 ;;; implementation can't do this.
 172
 173 ;(defun make-shareable-byte-vector (size)
 174 ;  "Create a Lisp vector of SIZE bytes can passed to
 175 ;WITH-POINTER-TO-VECTOR-DATA."
 176 ;  (make-array size :element-type '(unsigned-byte 8)))
 177 ;
 178 ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 179 ;  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 180 ;  `(sb-sys:without-gcing
 181 ;     (let ((,ptr-var (sb-sys:vector-sap ,vector)))
 182 ;       ,@body)))
 183
 184 ;;;# Dereferencing
 185
 186 (defun convert-foreign-type (type-keyword &optional (context :normal))
 187   "Convert a CFFI type keyword to an Allegro type."
 188   (ecase type-keyword
 189     (:char             :char)
 190     (:unsigned-char    :unsigned-char)
 191     (:short            :short)
 192     (:unsigned-short   :unsigned-short)
 193     (:int              :int)
 194     (:unsigned-int     :unsigned-int)
 195     (:long             :long)
 196     (:unsigned-long    :unsigned-long)
 197     (:float            :float)
 198     (:double           :double)
 199     (:pointer          (ecase context
 200                          (:normal '(* :void))
 201                          (:funcall :foreign-address)))
 202     (:void             :void)))
 203
 204 (defun %mem-ref (ptr type &optional (offset 0))
 205   "Dereference an object of TYPE at OFFSET bytes from PTR."
 206   (unless (zerop offset)
 207     (setf ptr (inc-pointer ptr offset)))
 208   (ff:fslot-value-typed (convert-foreign-type type) :c ptr))
 209
 210 ;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the
 211 ;;; CFFI type is constant.  Allegro does its own transformation on the
 212 ;;; call that results in efficient code.
 213 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
 214   (if (constantp type)
 215       (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
 216         `(ff:fslot-value-typed ',(convert-foreign-type (eval type))
 217                                :c ,ptr-form))
 218       form))
 219
 220 (defun %mem-set (value ptr type &optional (offset 0))
 221   "Set the object of TYPE at OFFSET bytes from PTR."
 222   (unless (zerop offset)
 223     (setf ptr (inc-pointer ptr offset)))
 224   (setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value))
 225
 226 ;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED)
 227 ;;; when the CFFI type is constant.  Allegro does its own
 228 ;;; transformation on the call that results in efficient code.
 229 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
 230   (if (constantp type)
 231       (once-only (val)
 232         (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
 233           `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval type))
 234                                        :c ,ptr-form) ,val)))
 235       form))
 236
 237 ;;;# Calling Foreign Functions
 238
 239 (defun %foreign-type-size (type-keyword)
 240   "Return the size in bytes of a foreign type."
 241   (ff:sizeof-fobject (convert-foreign-type type-keyword)))
 242
 243 (defun %foreign-type-alignment (type-keyword)
 244   "Returns the alignment in bytes of a foreign type."
 245   #+(and powerpc macosx32)
 246   (when (eq type-keyword :double)
 247     (return-from %foreign-type-alignment 8))
 248   ;; No override necessary for the remaining types....
 249   (ff::sized-ftype-prim-align
 250    (ff::iforeign-type-sftype
 251     (ff:get-foreign-type
 252      (convert-foreign-type type-keyword)))))
 253
 254 (defun foreign-funcall-type-and-args (args)
 255   "Returns a list of types, list of args and return type."
 256   (let ((return-type :void))
 257     (loop for (type arg) on args by #'cddr
 258           if arg collect (convert-foreign-type type :funcall) into types
 259           and collect arg into fargs
 260           else do (setf return-type (convert-foreign-type type :funcall))
 261           finally (return (values types fargs return-type)))))
 262
 263 (defun convert-to-lisp-type (type)
 264   (if (equal '(* :void) type)
 265       'integer
 266       (ecase type
 267         (:char 'signed-byte)
 268         (:unsigned-char 'integer) ;'unsigned-byte)
 269         ((:short
 270           :unsigned-short
 271           :int
 272           :unsigned-int
 273           :long
 274           :unsigned-long) 'integer)
 275         (:float 'single-float)
 276         (:double 'double-float)
 277         (:foreign-address :foreign-address)
 278         (:void 'null))))
 279
 280 (defun foreign-allegro-type (type)
 281   (if (eq type :foreign-address)
 282       nil
 283       type))
 284
 285 (defun allegro-type-pair (type)
 286   (list (foreign-allegro-type type)
 287         (convert-to-lisp-type type)))
 288
 289 #+ignore
 290 (defun note-named-foreign-function (symbol name types rettype)
 291   "Give Allegro's compiler a hint to perform a direct call."
 292   `(eval-when (:compile-toplevel :load-toplevel :execute)
 293      (setf (get ',symbol 'system::direct-ff-call)
 294            (list '(,name :language :c)
 295                  t  ; callback
 296                  :c ; convention
 297                  ;; return type '(:c-type lisp-type)
 298                  ',(allegro-type-pair (convert-foreign-type rettype :funcall))
 299                  ;; arg types '({(:c-type lisp-type)}*)
 300                  '(,@(loop for type in types
 301                            collect (allegro-type-pair
 302                                     (convert-foreign-type type :funcall))))
 303                  nil ; arg-checking
 304                  ff::ep-flag-never-release))))
 305
 306 (defmacro %foreign-funcall (name args &key calling-convention library)
 307   (declare (ignore calling-convention library))
 308   (multiple-value-bind (types fargs rettype)
 309       (foreign-funcall-type-and-args args)
 310     `(system::ff-funcall
 311       (load-time-value (excl::determine-foreign-address
 312                         '(,name :language :c)
 313                         ff::ep-flag-never-release
 314                         nil ; method-index
 315                         ))
 316       ;; arg types {'(:c-type lisp-type) argN}*
 317       ,@(mapcan (lambda (type arg)
 318                   `(',(allegro-type-pair type) ,arg))
 319                 types fargs)
 320       ;; return type '(:c-type lisp-type)
 321       ',(allegro-type-pair rettype))))
 322
 323 (defun defcfun-helper-forms (name lisp-name rettype args types options)
 324   "Return 2 values for DEFCFUN. A prelude form and a caller form."
 325   (declare (ignore options))
 326   (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
 327     (values
 328      `(ff:def-foreign-call (,ff-name ,name)
 329           ,(mapcar (lambda (ty)
 330                      (let ((allegro-type (convert-foreign-type ty)))
 331                        (list (gensym) allegro-type
 332                              (convert-to-lisp-type allegro-type))))
 333                    types)
 334         :returning ,(allegro-type-pair
 335                      (convert-foreign-type rettype :funcall))
 336         ;; Don't use call-direct when there are no arguments.
 337         ,@(unless (null args) '(:call-direct t))
 338         :arg-checking nil
 339         :strings-convert nil)
 340      `(,ff-name ,@args))))
 341
 342 ;;; See doc/allegro-internals.txt for a clue about entry-vec.
 343 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
 344   (declare (ignore calling-convention))
 345   (multiple-value-bind (types fargs rettype)
 346       (foreign-funcall-type-and-args args)
 347     (with-unique-names (entry-vec)
 348       `(let ((,entry-vec (excl::make-entry-vec-boa)))
 349          (setf (aref ,entry-vec 1) ,ptr) ; set jump address
 350          (system::ff-funcall
 351           ,entry-vec
 352           ;; arg types {'(:c-type lisp-type) argN}*
 353           ,@(mapcan (lambda (type arg)
 354                       `(',(allegro-type-pair type) ,arg))
 355                     types fargs)
 356           ;; return type '(:c-type lisp-type)
 357           ',(allegro-type-pair rettype))))))
 358
 359 ;;;# Callbacks
 360
 361 ;;; The *CALLBACKS* hash table contains information about a callback
 362 ;;; for the Allegro FFI.  The key is the name of the CFFI callback,
 363 ;;; and the value is a cons, the car containing the symbol the
 364 ;;; callback was defined on in the CFFI-CALLBACKS package, the cdr
 365 ;;; being an Allegro FFI pointer (a fixnum) that can be passed to C
 366 ;;; functions.
 367 ;;;
 368 ;;; These pointers must be restored when a saved Lisp image is loaded.
 369 ;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to
 370 ;;; re-register the callbacks during Lisp startup.
 371 (defvar *callbacks* (make-hash-table))
 372
 373 ;;; Register a callback in the *CALLBACKS* hash table.
 374 (defun register-callback (cffi-name callback-name)
 375   (setf (gethash cffi-name *callbacks*)
 376         (cons callback-name (ff:register-foreign-callable
 377                              callback-name :reuse t))))
 378
 379 ;;; Restore the saved pointers in *CALLBACKS* when loading an image.
 380 (defun restore-callbacks ()
 381   (maphash (lambda (key value)
 382              (register-callback key (car value)))
 383            *callbacks*))
 384
 385 ;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing
 386 ;;; CFFI is restarted.
 387 (eval-when (:load-toplevel :execute)
 388   (pushnew 'restore-callbacks excl:*restart-actions*))
 389
 390 ;;; Create a package to contain the symbols for callback functions.
 391 (defpackage #:cffi-callbacks
 392   (:use))
 393
 394 (defun intern-callback (name)
 395   (intern (format nil "~A::~A" (package-name (symbol-package name))
 396                   (symbol-name name))
 397           '#:cffi-callbacks))
 398
 399 (defun convert-cconv (cconv)
 400   (ecase cconv
 401     (:cdecl :c)
 402     (:stdcall :stdcall)))
 403
 404 (defmacro %defcallback (name rettype arg-names arg-types body
 405                         &key calling-convention)
 406   (declare (ignore rettype))
 407   (let ((cb-name (intern-callback name)))
 408     `(progn
 409        (ff:defun-foreign-callable ,cb-name
 410            ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
 411                     arg-names arg-types)
 412          (declare (:convention ,(convert-cconv calling-convention)))
 413          ,body)
 414        (register-callback ',name ',cb-name))))
 415
 416 ;;; Return the saved Lisp callback pointer from *CALLBACKS* for the
 417 ;;; CFFI callback named NAME.
 418 (defun %callback (name)
 419   (or (cdr (gethash name *callbacks*))
 420       (error "Undefined callback: ~S" name)))
 421
 422 ;;;# Loading and Closing Foreign Libraries
 423
 424 (defun %load-foreign-library (name path)
 425   "Load a foreign library."
 426   ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load
 427   ;; the argument. However, previous versions do not and will only
 428   ;; foreign load the argument if its type is a member of the
 429   ;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special
 430   ;; to a list containing whatever type NAME has.
 431   (declare (ignore name))
 432   (let ((excl::*load-foreign-types*
 433          (list (pathname-type (parse-namestring path)))))
 434     (handler-case
 435         (progn
 436           #+(version>= 7) (load path :foreign t)
 437           #-(version>= 7) (load path))
 438       (file-error (fe)
 439         (error (change-class fe 'simple-error))))
 440     path))
 441
 442 (defun %close-foreign-library (name)
 443   "Close the foreign library NAME."
 444   (ff:unload-foreign-library name))
 445
 446 (defun native-namestring (pathname)
 447   (namestring pathname))
 448
 449 ;;;# Foreign Globals
 450
 451 (defun convert-external-name (name)
 452   "Add an underscore to NAME if necessary for the ABI."
 453   #+macosx (concatenate 'string "_" name)
 454   #-macosx name)
 455
 456 (defun %foreign-symbol-pointer (name library)
 457   "Returns a pointer to a foreign symbol NAME."
 458   (declare (ignore library))
 459   (prog1 (ff:get-entry-point (convert-external-name name))))