cffi-sbcl.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-sbcl.lisp (14835B) | |
--- | |
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 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 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 #+(and darwin sb-thread) (call-within-initial-thread 'load-shared-obje… | |
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))) |