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