cffi-sbcl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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 <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)))