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