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