3rdparties/software/cffi_0.21.0/src/cffi-sbcl.lisp (14835 bytes)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL. 4 ;;; 5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com> 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 #:sb-alien) 32 (:import-from #:alexandria 33 #:once-only #:with-unique-names #:when-let #:removef) 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 ;;;# Misfeatures 65 66 (pushnew 'flat-namespace *features*) 67 68 ;;;# Symbol Case 69 70 (declaim (inline canonicalize-symbol-name-case)) 71 (defun canonicalize-symbol-name-case (name) 72 (declare (string name)) 73 (string-upcase name)) 74 75 ;;;# Basic Pointer Operations 76 77 (deftype foreign-pointer () 78 'sb-sys:system-area-pointer) 79 80 (declaim (inline pointerp)) 81 (defun pointerp (ptr) 82 "Return true if PTR is a foreign pointer." 83 (sb-sys:system-area-pointer-p ptr)) 84 85 (declaim (inline pointer-eq)) 86 (defun pointer-eq (ptr1 ptr2) 87 "Return true if PTR1 and PTR2 point to the same address." 88 (declare (type system-area-pointer ptr1 ptr2)) 89 (sb-sys:sap= ptr1 ptr2)) 90 91 (declaim (inline null-pointer)) 92 (defun null-pointer () 93 "Construct and return a null pointer." 94 (sb-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 (declare (type system-area-pointer ptr)) 100 (zerop (sb-sys:sap-int ptr))) 101 102 (declaim (inline inc-pointer)) 103 (defun inc-pointer (ptr offset) 104 "Return a pointer pointing OFFSET bytes past PTR." 105 (declare (type system-area-pointer ptr) 106 (type integer offset)) 107 (sb-sys:sap+ ptr offset)) 108 109 (declaim (inline make-pointer)) 110 (defun make-pointer (address) 111 "Return a pointer pointing to ADDRESS." 112 ;; (declare (type (unsigned-byte 32) address)) 113 (sb-sys:int-sap address)) 114 115 (declaim (inline pointer-address)) 116 (defun pointer-address (ptr) 117 "Return the address pointed to by PTR." 118 (declare (type system-area-pointer ptr)) 119 (sb-sys:sap-int ptr)) 120 121 ;;;# Allocation 122 ;;; 123 ;;; Functions and macros for allocating foreign memory on the stack 124 ;;; and on the heap. The main CFFI package defines macros that wrap 125 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage 126 ;;; when the memory has dynamic extent. 127 128 (declaim (inline %foreign-alloc)) 129 (defun %foreign-alloc (size) 130 "Allocate SIZE bytes on the heap and return a pointer." 131 ;; (declare (type (unsigned-byte 32) size)) 132 (alien-sap (make-alien (unsigned 8) size))) 133 134 (declaim (inline foreign-free)) 135 (defun foreign-free (ptr) 136 "Free a PTR allocated by FOREIGN-ALLOC." 137 (declare (type system-area-pointer ptr) 138 (optimize speed)) 139 (free-alien (sap-alien ptr (* (unsigned 8))))) 140 141 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) 142 "Bind VAR to SIZE bytes of foreign memory during BODY. The 143 pointer in VAR is invalid beyond the dynamic extent of BODY, and 144 may be stack-allocated if supported by the implementation. If 145 SIZE-VAR is supplied, it will be bound to SIZE during BODY." 146 (unless size-var 147 (setf size-var (gensym "SIZE"))) 148 ;; If the size is constant we can stack-allocate. 149 (if (constantp size) 150 (let ((alien-var (gensym "ALIEN"))) 151 `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) 152 (let ((,size-var ,(eval size)) 153 (,var (alien-sap ,alien-var))) 154 (declare (ignorable ,size-var)) 155 ,@body))) 156 `(let* ((,size-var ,size) 157 (,var (%foreign-alloc ,size-var))) 158 (unwind-protect 159 (progn ,@body) 160 (foreign-free ,var))))) 161 162 ;;;# Shareable Vectors 163 ;;; 164 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA 165 ;;; should be defined to perform a copy-in/copy-out if the Lisp 166 ;;; implementation can't do this. 167 168 (declaim (inline make-shareable-byte-vector)) 169 (defun make-shareable-byte-vector (size) 170 "Create a Lisp vector of SIZE bytes that can be passed to 171 WITH-POINTER-TO-VECTOR-DATA." 172 ; (declare (type sb-int:index size)) 173 (make-array size :element-type '(unsigned-byte 8))) 174 175 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) 176 "Bind PTR-VAR to a foreign pointer to the data in VECTOR." 177 (let ((vector-var (gensym "VECTOR"))) 178 `(let ((,vector-var ,vector)) 179 (declare (type (sb-kernel:simple-unboxed-array (*)) ,vector-var)) 180 (sb-sys:with-pinned-objects (,vector-var) 181 (let ((,ptr-var (sb-sys:vector-sap ,vector-var))) 182 ,@body))))) 183 184 ;;;# Dereferencing 185 186 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler 187 ;;; macros that optimize the case where the type keyword is constant 188 ;;; at compile-time. 189 (defmacro define-mem-accessors (&body pairs) 190 `(progn 191 (defun %mem-ref (ptr type &optional (offset 0)) 192 (ecase type 193 ,@(loop for (keyword fn) in pairs 194 collect `(,keyword (,fn ptr offset))))) 195 (defun %mem-set (value ptr type &optional (offset 0)) 196 (ecase type 197 ,@(loop for (keyword fn) in pairs 198 collect `(,keyword (setf (,fn ptr offset) value))))) 199 (define-compiler-macro %mem-ref 200 (&whole form ptr type &optional (offset 0)) 201 (if (constantp type) 202 (ecase (eval type) 203 ,@(loop for (keyword fn) in pairs 204 collect `(,keyword `(,',fn ,ptr ,offset)))) 205 form)) 206 (define-compiler-macro %mem-set 207 (&whole form value ptr type &optional (offset 0)) 208 (if (constantp type) 209 (once-only (value) 210 (ecase (eval type) 211 ,@(loop for (keyword fn) in pairs 212 collect `(,keyword `(setf (,',fn ,ptr ,offset) 213 ,value))))) 214 form)))) 215 216 ;;; Look up alien type information and build both define-mem-accessors form 217 ;;; and convert-foreign-type function definition. 218 (defmacro define-type-mapping (accessor-table alien-table) 219 (let* ((accessible-types 220 (remove 'void alien-table :key #'second)) 221 (size-and-signedp-forms 222 (mapcar (lambda (name) 223 (list (eval `(alien-size ,(second name))) 224 (typep -1 `(alien ,(second name))))) 225 accessible-types))) 226 `(progn 227 (define-mem-accessors 228 ,@(loop for (cffi-keyword alien-type fixed-accessor) 229 in accessible-types 230 and (alien-size signedp) 231 in size-and-signedp-forms 232 for (signed-ref unsigned-ref) 233 = (cdr (assoc alien-size accessor-table)) 234 collect 235 `(,cffi-keyword 236 ,(or fixed-accessor 237 (if signedp signed-ref unsigned-ref) 238 (error "No accessor found for ~S" 239 alien-type))))) 240 (defun convert-foreign-type (type-keyword) 241 (ecase type-keyword 242 ,@(loop for (cffi-keyword alien-type) in alien-table 243 collect `(,cffi-keyword (quote ,alien-type)))))))) 244 245 (define-type-mapping 246 ((8 sb-sys:signed-sap-ref-8 sb-sys:sap-ref-8) 247 (16 sb-sys:signed-sap-ref-16 sb-sys:sap-ref-16) 248 (32 sb-sys:signed-sap-ref-32 sb-sys:sap-ref-32) 249 (64 sb-sys:signed-sap-ref-64 sb-sys:sap-ref-64)) 250 ((:char char) 251 (:unsigned-char unsigned-char) 252 (:short short) 253 (:unsigned-short unsigned-short) 254 (:int int) 255 (:unsigned-int unsigned-int) 256 (:long long) 257 (:unsigned-long unsigned-long) 258 (:long-long long-long) 259 (:unsigned-long-long unsigned-long-long) 260 (:float single-float 261 sb-sys:sap-ref-single) 262 (:double double-float 263 sb-sys:sap-ref-double) 264 (:pointer system-area-pointer 265 sb-sys:sap-ref-sap) 266 (:void void))) 267 268 ;;;# Calling Foreign Functions 269 270 (defun %foreign-type-size (type-keyword) 271 "Return the size in bytes of a foreign type." 272 (/ (sb-alien-internals:alien-type-bits 273 (sb-alien-internals:parse-alien-type 274 (convert-foreign-type type-keyword) nil)) 8)) 275 276 (defun %foreign-type-alignment (type-keyword) 277 "Return the alignment in bytes of a foreign type." 278 #+(and darwin ppc (not ppc64)) 279 (case type-keyword 280 ((:double :long-long :unsigned-long-long) 281 (return-from %foreign-type-alignment 8))) 282 ;; No override necessary for other types... 283 (/ (sb-alien-internals:alien-type-alignment 284 (sb-alien-internals:parse-alien-type 285 (convert-foreign-type type-keyword) nil)) 8)) 286 287 (defun foreign-funcall-type-and-args (args) 288 "Return an SB-ALIEN function type for ARGS." 289 (let ((return-type 'void)) 290 (loop for (type arg) on args by #'cddr 291 if arg collect (convert-foreign-type type) into types 292 and collect arg into fargs 293 else do (setf return-type (convert-foreign-type type)) 294 finally (return (values types fargs return-type))))) 295 296 (defmacro %%foreign-funcall (name types fargs rettype) 297 "Internal guts of %FOREIGN-FUNCALL." 298 `(alien-funcall 299 (extern-alien ,name (function ,rettype ,@types)) 300 ,@fargs)) 301 302 (defmacro %foreign-funcall (name args &key library convention) 303 "Perform a foreign function call, document it more later." 304 (declare (ignore library convention)) 305 (multiple-value-bind (types fargs rettype) 306 (foreign-funcall-type-and-args args) 307 `(%%foreign-funcall ,name ,types ,fargs ,rettype))) 308 309 (defmacro %foreign-funcall-pointer (ptr args &key convention) 310 "Funcall a pointer to a foreign function." 311 (declare (ignore convention)) 312 (multiple-value-bind (types fargs rettype) 313 (foreign-funcall-type-and-args args) 314 (with-unique-names (function) 315 `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr)) 316 (alien-funcall ,function ,@fargs))))) 317 318 ;;;# Callbacks 319 320 ;;; The *CALLBACKS* hash table contains a direct mapping of CFFI 321 ;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA. 322 ;;; SBCL will maintain the addresses of the callbacks across saved 323 ;;; images, so it is safe to store the pointers directly. 324 (defvar *callbacks* (make-hash-table)) 325 326 (defmacro %defcallback (name rettype arg-names arg-types body 327 &key convention) 328 (check-type convention (member :stdcall :cdecl)) 329 `(setf (gethash ',name *callbacks*) 330 (alien-sap 331 (sb-alien::alien-lambda 332 #+alien-callback-conventions 333 (,convention ,(convert-foreign-type rettype)) 334 #-alien-callback-conventions 335 ,(convert-foreign-type rettype) 336 ,(mapcar (lambda (sym type) 337 (list sym (convert-foreign-type type))) 338 arg-names arg-types) 339 ,body)))) 340 341 (defun %callback (name) 342 (or (gethash name *callbacks*) 343 (error "Undefined callback: ~S" name))) 344 345 ;;;# Loading and Closing Foreign Libraries 346 347 #+darwin 348 (defun call-within-initial-thread (fn &rest args) 349 (let (result 350 error 351 (sem (sb-thread:make-semaphore))) 352 (sb-thread:interrupt-thread 353 ;; KLUDGE: find a better way to get the initial thread. 354 (car (last (sb-thread:list-all-threads))) 355 (lambda () 356 (multiple-value-setq (result error) 357 (ignore-errors (apply fn args))) 358 (sb-thread:signal-semaphore sem))) 359 (sb-thread:wait-on-semaphore sem) 360 (if error 361 (signal error) 362 result))) 363 364 (declaim (inline %load-foreign-library)) 365 (defun %load-foreign-library (name path) 366 "Load a foreign library." 367 (declare (ignore name)) 368 ;; As of MacOS X 10.6.6, loading things like CoreFoundation from a 369 ;; thread other than the initial one results in a crash. 370 #+(and darwin sb-thread) (call-within-initial-thread 'load-shared-object path) 371 #-(and darwin sb-thread) (load-shared-object path)) 372 373 ;;; SBCL 1.0.21.15 renamed SB-ALIEN::SHARED-OBJECT-FILE but introduced 374 ;;; SB-ALIEN:UNLOAD-SHARED-OBJECT which we can use instead. 375 (eval-when (:compile-toplevel :load-toplevel :execute) 376 (defun unload-shared-object-present-p () 377 (multiple-value-bind (foundp kind) 378 (find-symbol "UNLOAD-SHARED-OBJECT" "SB-ALIEN") 379 (if (and foundp (eq kind :external)) 380 '(:and) 381 '(:or))))) 382 383 (defun %close-foreign-library (handle) 384 "Closes a foreign library." 385 #+#.(cffi-sys::unload-shared-object-present-p) 386 (sb-alien:unload-shared-object handle) 387 #-#.(cffi-sys::unload-shared-object-present-p) 388 (sb-thread:with-mutex (sb-alien::*shared-objects-lock*) 389 (let ((obj (find (sb-ext:native-namestring handle) 390 sb-alien::*shared-objects* 391 :key #'sb-alien::shared-object-file 392 :test #'string=))) 393 (when obj 394 (sb-alien::dlclose-or-lose obj) 395 (removef sb-alien::*shared-objects* obj) 396 #-win32 397 (sb-alien::update-linkage-table))))) 398 399 (defun native-namestring (pathname) 400 (sb-ext:native-namestring pathname)) 401 402 ;;;# Foreign Globals 403 404 (defun %foreign-symbol-pointer (name library) 405 "Returns a pointer to a foreign symbol NAME." 406 (declare (ignore library)) 407 (when-let (address (sb-sys:find-foreign-symbol-address name)) 408 (sb-sys:int-sap address)))