src/cffi-scl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;; Copyright (C) 2006-2007, Scieneer Pty Ltd.
   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 #:alien #:c-call)
  33   (:import-from #:alexandria #:once-only #:with-unique-names)
  34   (:export
  35    #:canonicalize-symbol-name-case
  36    #:foreign-pointer
  37    #:pointerp
  38    #:pointer-eq
  39    #:null-pointer
  40    #:null-pointer-p
  41    #:inc-pointer
  42    #:make-pointer
  43    #:pointer-address
  44    #:%foreign-alloc
  45    #:foreign-free
  46    #:with-foreign-pointer
  47    #:%foreign-funcall
  48    #:%foreign-funcall-pointer
  49    #:%foreign-type-alignment
  50    #:%foreign-type-size
  51    #:%load-foreign-library
  52    #:%close-foreign-library
  53    #:native-namestring
  54    #:%mem-ref
  55    #:%mem-set
  56    #:make-shareable-byte-vector
  57    #:with-pointer-to-vector-data
  58    #:%foreign-symbol-pointer
  59    #:%defcallback
  60    #:%callback))
  61
  62 (in-package #:cffi-sys)
  63
  64 ;;;# Mis-features
  65
  66 (pushnew 'flat-namespace *features*)
  67
  68 ;;;# Symbol Case
  69
  70 (defun canonicalize-symbol-name-case (name)
  71   (declare (string name))
  72   (if (eq ext:*case-mode* :upper)
  73       (string-upcase name)
  74       (string-downcase name)))
  75
  76 ;;;# Basic Pointer Operations
  77
  78 (deftype foreign-pointer ()
  79   'sys:system-area-pointer)
  80
  81 (declaim (inline pointerp))
  82 (defun pointerp (ptr)
  83   "Return true if 'ptr is a foreign pointer."
  84   (sys:system-area-pointer-p ptr))
  85
  86 (declaim (inline pointer-eq))
  87 (defun pointer-eq (ptr1 ptr2)
  88   "Return true if 'ptr1 and 'ptr2 point to the same address."
  89   (sys:sap= ptr1 ptr2))
  90
  91 (declaim (inline null-pointer))
  92 (defun null-pointer ()
  93   "Construct and return a null pointer."
  94   (sys:int-sap 0))
  95
  96 (declaim (inline null-pointer-p))
  97 (defun null-pointer-p (ptr)
  98   "Return true if 'ptr is a null pointer."
  99   (zerop (sys:sap-int ptr)))
 100
 101 (declaim (inline inc-pointer))
 102 (defun inc-pointer (ptr offset)
 103   "Return a pointer pointing 'offset bytes past 'ptr."
 104   (sys:sap+ ptr offset))
 105
 106 (declaim (inline make-pointer))
 107 (defun make-pointer (address)
 108   "Return a pointer pointing to 'address."
 109   (sys:int-sap address))
 110
 111 (declaim (inline pointer-address))
 112 (defun pointer-address (ptr)
 113   "Return the address pointed to by 'ptr."
 114   (sys:sap-int ptr))
 115
 116 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 117   "Bind 'var to 'size bytes of foreign memory during 'body.  The
 118   pointer in 'var is invalid beyond the dynamic extent of 'body, and
 119   may be stack-allocated if supported by the implementation.  If
 120   'size-var is supplied, it will be bound to 'size during 'body."
 121   (unless size-var
 122     (setf size-var (gensym (symbol-name '#:size))))
 123   ;; If the size is constant we can stack-allocate.
 124   (cond ((constantp size)
 125          (let ((alien-var (gensym (symbol-name '#:alien))))
 126            `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
 127              (let ((,size-var ,size)
 128                    (,var (alien-sap ,alien-var)))
 129                (declare (ignorable ,size-var))
 130                ,@body))))
 131         (t
 132          `(let ((,size-var ,size))
 133             (alien:with-bytes (,var ,size-var)
 134               ,@body)))))
 135
 136 ;;;# Allocation
 137 ;;;
 138 ;;; Functions and macros for allocating foreign memory on the stack and on the
 139 ;;; heap.  The main CFFI package defines macros that wrap 'foreign-alloc and
 140 ;;; 'foreign-free in 'unwind-protect for the common usage when the memory has
 141 ;;; dynamic extent.
 142
 143 (defun %foreign-alloc (size)
 144   "Allocate 'size bytes on the heap and return a pointer."
 145   (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
 146   (alien-funcall (extern-alien "malloc"
 147                                (function system-area-pointer unsigned))
 148                  size))
 149
 150 (defun foreign-free (ptr)
 151   "Free a 'ptr allocated by 'foreign-alloc."
 152   (declare (type system-area-pointer ptr))
 153   (alien-funcall (extern-alien "free"
 154                                (function (values) system-area-pointer))
 155                  ptr))
 156
 157 ;;;# Shareable Vectors
 158
 159 (defun make-shareable-byte-vector (size)
 160   "Create a Lisp vector of 'size bytes that can passed to
 161   'with-pointer-to-vector-data."
 162   (make-array size :element-type '(unsigned-byte 8)))
 163
 164 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 165   "Bind 'ptr-var to a foreign pointer to the data in 'vector."
 166   (let ((vector-var (gensym (symbol-name '#:vector))))
 167     `(let ((,vector-var ,vector))
 168        (ext:with-pinned-object (,vector-var)
 169          (let ((,ptr-var (sys:vector-sap ,vector-var)))
 170            ,@body)))))
 171
 172 ;;;# Dereferencing
 173
 174 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
 175 ;;; macros that optimize the case where the type keyword is constant
 176 ;;; at compile-time.
 177 (defmacro define-mem-accessors (&body pairs)
 178   `(progn
 179     (defun %mem-ref (ptr type &optional (offset 0))
 180       (ecase type
 181         ,@(loop for (keyword fn) in pairs
 182                 collect `(,keyword (,fn ptr offset)))))
 183     (defun %mem-set (value ptr type &optional (offset 0))
 184       (ecase type
 185         ,@(loop for (keyword fn) in pairs
 186                 collect `(,keyword (setf (,fn ptr offset) value)))))
 187     (define-compiler-macro %mem-ref
 188         (&whole form ptr type &optional (offset 0))
 189       (if (constantp type)
 190           (ecase (eval type)
 191             ,@(loop for (keyword fn) in pairs
 192                     collect `(,keyword `(,',fn ,ptr ,offset))))
 193           form))
 194     (define-compiler-macro %mem-set
 195         (&whole form value ptr type &optional (offset 0))
 196       (if (constantp type)
 197           (once-only (value)
 198             (ecase (eval type)
 199               ,@(loop for (keyword fn) in pairs
 200                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
 201                                                 ,value)))))
 202           form))))
 203
 204 (define-mem-accessors
 205   (:char sys:signed-sap-ref-8)
 206   (:unsigned-char sys:sap-ref-8)
 207   (:short sys:signed-sap-ref-16)
 208   (:unsigned-short sys:sap-ref-16)
 209   (:int sys:signed-sap-ref-32)
 210   (:unsigned-int sys:sap-ref-32)
 211   (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
 212   (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
 213   (:long-long sys:signed-sap-ref-64)
 214   (:unsigned-long-long sys:sap-ref-64)
 215   (:float sys:sap-ref-single)
 216   (:double sys:sap-ref-double)
 217   #+long-float (:long-double sys:sap-ref-long)
 218   (:pointer sys:sap-ref-sap))
 219
 220 ;;;# Calling Foreign Functions
 221
 222 (defun convert-foreign-type (type-keyword)
 223   "Convert a CFFI type keyword to an ALIEN type."
 224   (ecase type-keyword
 225     (:char               'char)
 226     (:unsigned-char      'unsigned-char)
 227     (:short              'short)
 228     (:unsigned-short     'unsigned-short)
 229     (:int                'int)
 230     (:unsigned-int       'unsigned-int)
 231     (:long               'long)
 232     (:unsigned-long      'unsigned-long)
 233     (:long-long          '(signed 64))
 234     (:unsigned-long-long '(unsigned 64))
 235     (:float              'single-float)
 236     (:double             'double-float)
 237     #+long-float
 238     (:long-double        'long-float)
 239     (:pointer            'system-area-pointer)
 240     (:void               'void)))
 241
 242 (defun %foreign-type-size (type-keyword)
 243   "Return the size in bytes of a foreign type."
 244   (values (truncate (alien-internals:alien-type-bits
 245                      (alien-internals:parse-alien-type
 246                       (convert-foreign-type type-keyword)))
 247                     8)))
 248
 249 (defun %foreign-type-alignment (type-keyword)
 250   "Return the alignment in bytes of a foreign type."
 251   (values (truncate (alien-internals:alien-type-alignment
 252                      (alien-internals:parse-alien-type
 253                       (convert-foreign-type type-keyword)))
 254                     8)))
 255
 256 (defun foreign-funcall-type-and-args (args)
 257   "Return an 'alien function type for 'args."
 258   (let ((return-type nil))
 259     (loop for (type arg) on args by #'cddr
 260           if arg collect (convert-foreign-type type) into types
 261           and collect arg into fargs
 262           else do (setf return-type (convert-foreign-type type))
 263           finally (return (values types fargs return-type)))))
 264
 265 (defmacro %%foreign-funcall (name types fargs rettype)
 266   "Internal guts of '%foreign-funcall."
 267   `(alien-funcall (extern-alien ,name (function ,rettype ,@types))
 268                   ,@fargs))
 269
 270 (defmacro %foreign-funcall (name args &key library convention)
 271   "Perform a foreign function call, document it more later."
 272   (declare (ignore library convention))
 273   (multiple-value-bind (types fargs rettype)
 274       (foreign-funcall-type-and-args args)
 275     `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
 276
 277 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 278   "Funcall a pointer to a foreign function."
 279   (declare (ignore convention))
 280   (multiple-value-bind (types fargs rettype)
 281       (foreign-funcall-type-and-args args)
 282     (with-unique-names (function)
 283       `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
 284          (alien-funcall ,function ,@fargs)))))
 285
 286 ;;; Callbacks
 287
 288 (defmacro %defcallback (name rettype arg-names arg-types body
 289                         &key convention)
 290   (declare (ignore convention))
 291    `(alien:defcallback ,name
 292        (,(convert-foreign-type rettype)
 293          ,@(mapcar (lambda (sym type)
 294                      (list sym (convert-foreign-type type)))
 295                    arg-names arg-types))
 296      ,body))
 297
 298 (declaim (inline %callback))
 299 (defun %callback (name)
 300   (alien:callback-sap name))
 301
 302 ;;;# Loading and Closing Foreign Libraries
 303
 304 (defun %load-foreign-library (name path)
 305   "Load the foreign library 'name."
 306   (declare (ignore name))
 307   (ext:load-dynamic-object path))
 308
 309 (defun %close-foreign-library (name)
 310   "Closes the foreign library 'name."
 311   (ext:close-dynamic-object name))
 312
 313 (defun native-namestring (pathname)
 314   (ext:unix-namestring pathname nil))
 315
 316 ;;;# Foreign Globals
 317
 318 (defun %foreign-symbol-pointer (name library)
 319   "Returns a pointer to a foreign symbol 'name."
 320   (declare (ignore library))
 321   (let ((sap (sys:foreign-symbol-address name)))
 322     (if (zerop (sys:sap-int sap)) nil sap)))