GopherProxy

	tcffi-sbcl.lisp - clic - Clic is an command line interactive client for gopher …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tcffi-sbcl.lisp (14821B)
	---
	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 <[email protected]>
	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 can 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 f…
	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 #+darwin (call-within-initial-thread 'load-shared-object path)
	371 #-darwin (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 #+(and linkage-table (not 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)))