cffi-lispworks.lisp - clic - Clic is an command line interactive client for gop… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-lispworks.lisp (15916B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-lispworks.lisp --- Lispworks CFFI-SYS implementation. | |
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 #:cl #:alexandria) | |
32 (:export | |
33 #:canonicalize-symbol-name-case | |
34 #:foreign-pointer | |
35 #:pointerp | |
36 #:pointer-eq | |
37 #:null-pointer | |
38 #:null-pointer-p | |
39 #:inc-pointer | |
40 #:make-pointer | |
41 #:pointer-address | |
42 #:%foreign-alloc | |
43 #:foreign-free | |
44 #:with-foreign-pointer | |
45 #:%foreign-funcall | |
46 #:%foreign-funcall-pointer | |
47 #:%foreign-type-alignment | |
48 #:%foreign-type-size | |
49 #:%load-foreign-library | |
50 #:%close-foreign-library | |
51 #:native-namestring | |
52 #:%mem-ref | |
53 #:%mem-set | |
54 #:make-shareable-byte-vector | |
55 #:with-pointer-to-vector-data | |
56 #:%foreign-symbol-pointer | |
57 #:defcfun-helper-forms | |
58 #:%defcallback | |
59 #:%callback)) | |
60 | |
61 (in-package #:cffi-sys) | |
62 | |
63 ;;;# Misfeatures | |
64 | |
65 #-lispworks-64bit (pushnew 'no-long-long *features*) | |
66 | |
67 ;;;# Symbol Case | |
68 | |
69 (defun canonicalize-symbol-name-case (name) | |
70 (declare (string name)) | |
71 (string-upcase name)) | |
72 | |
73 ;;;# Basic Pointer Operations | |
74 | |
75 (deftype foreign-pointer () | |
76 'fli::pointer) | |
77 | |
78 (defun pointerp (ptr) | |
79 "Return true if PTR is a foreign pointer." | |
80 (fli:pointerp ptr)) | |
81 | |
82 (defun pointer-eq (ptr1 ptr2) | |
83 "Return true if PTR1 and PTR2 point to the same address." | |
84 (fli:pointer-eq ptr1 ptr2)) | |
85 | |
86 ;; We use FLI:MAKE-POINTER here instead of FLI:*NULL-POINTER* since old | |
87 ;; versions of Lispworks don't seem to have it. | |
88 (defun null-pointer () | |
89 "Return a null foreign pointer." | |
90 (fli:make-pointer :address 0 :type :void)) | |
91 | |
92 (defun null-pointer-p (ptr) | |
93 "Return true if PTR is a null pointer." | |
94 (check-type ptr fli::pointer) | |
95 (fli:null-pointer-p ptr)) | |
96 | |
97 ;; FLI:INCF-POINTER won't work on FLI pointers to :void so we | |
98 ;; increment "manually." | |
99 (defun inc-pointer (ptr offset) | |
100 "Return a pointer OFFSET bytes past PTR." | |
101 (fli:make-pointer :type :void :address (+ (fli:pointer-address ptr) of… | |
102 | |
103 (defun make-pointer (address) | |
104 "Return a pointer pointing to ADDRESS." | |
105 (fli:make-pointer :type :void :address address)) | |
106 | |
107 (defun pointer-address (ptr) | |
108 "Return the address pointed to by PTR." | |
109 (fli:pointer-address ptr)) | |
110 | |
111 ;;;# Allocation | |
112 | |
113 (defun %foreign-alloc (size) | |
114 "Allocate SIZE bytes of memory and return a pointer." | |
115 (fli:allocate-foreign-object :type :byte :nelems size)) | |
116 | |
117 (defun foreign-free (ptr) | |
118 "Free a pointer PTR allocated by FOREIGN-ALLOC." | |
119 (fli:free-foreign-object ptr)) | |
120 | |
121 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
122 "Bind VAR to SIZE bytes of foreign memory during BODY. Both the | |
123 pointer in VAR and the memory it points to have dynamic extent and may | |
124 be stack allocated if supported by the implementation." | |
125 (unless size-var | |
126 (setf size-var (gensym "SIZE"))) | |
127 `(fli:with-dynamic-foreign-objects () | |
128 (let* ((,size-var ,size) | |
129 (,var (fli:alloca :type :byte :nelems ,size-var))) | |
130 ,@body))) | |
131 | |
132 ;;;# Shareable Vectors | |
133 | |
134 (defun make-shareable-byte-vector (size) | |
135 "Create a shareable byte vector." | |
136 #+(or lispworks3 lispworks4 lispworks5.0) | |
137 (sys:in-static-area | |
138 (make-array size :element-type '(unsigned-byte 8))) | |
139 #-(or lispworks3 lispworks4 lispworks5.0) | |
140 (make-array size :element-type '(unsigned-byte 8) :allocation :static)) | |
141 | |
142 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) | |
143 "Bind PTR-VAR to a pointer at the data in VECTOR." | |
144 `(fli:with-dynamic-lisp-array-pointer (,ptr-var ,vector) | |
145 ,@body)) | |
146 | |
147 ;;;# Dereferencing | |
148 | |
149 (defun convert-foreign-type (cffi-type) | |
150 "Convert a CFFI type keyword to an FLI type." | |
151 (ecase cffi-type | |
152 (:char :byte) | |
153 (:unsigned-char '(:unsigned :byte)) | |
154 (:short :short) | |
155 (:unsigned-short '(:unsigned :short)) | |
156 (:int :int) | |
157 (:unsigned-int '(:unsigned :int)) | |
158 (:long :long) | |
159 (:unsigned-long '(:unsigned :long)) | |
160 ;; On 32-bit platforms, Lispworks 5.0+ supports long-long for | |
161 ;; DEFCFUN and FOREIGN-FUNCALL. | |
162 (:long-long '(:long :long)) | |
163 (:unsigned-long-long '(:unsigned :long :long)) | |
164 (:float :float) | |
165 (:double :double) | |
166 (:pointer :pointer) | |
167 (:void :void))) | |
168 | |
169 ;;; Convert a CFFI type keyword to a symbol suitable for passing to | |
170 ;;; FLI:FOREIGN-TYPED-AREF. | |
171 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) | |
172 (defun convert-foreign-typed-aref-type (cffi-type) | |
173 (ecase cffi-type | |
174 ((:char :short :int :long #+lispworks-64bit :long-long) | |
175 `(signed-byte ,(* 8 (%foreign-type-size cffi-type)))) | |
176 ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long | |
177 #+lispworks-64bit :unsigned-long-long) | |
178 `(unsigned-byte ,(* 8 (%foreign-type-size cffi-type)))) | |
179 (:float 'single-float) | |
180 (:double 'double-float))) | |
181 | |
182 (defun %mem-ref (ptr type &optional (offset 0)) | |
183 "Dereference an object of type TYPE OFFSET bytes from PTR." | |
184 (unless (zerop offset) | |
185 (setf ptr (inc-pointer ptr offset))) | |
186 (fli:dereference ptr :type (convert-foreign-type type))) | |
187 | |
188 ;; Lispworks 5.0 on 64-bit platforms doesn't have [u]int64 support in | |
189 ;; FOREIGN-TYPED-AREF. That was implemented in 5.1. | |
190 #+(and lispworks-64bit lispworks5.0) | |
191 (defun 64-bit-type-p (type) | |
192 (member type '(:long :unsigned-long :long-long :unsigned-long-long))) | |
193 | |
194 ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use | |
195 ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF. | |
196 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) | |
197 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) | |
198 (if (constantp type) | |
199 (let ((type (eval type))) | |
200 (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type) | |
201 (eql type :pointer)) | |
202 (let ((fli-type (convert-foreign-type type)) | |
203 (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)… | |
204 `(fli:dereference ,ptr-form :type ',fli-type)) | |
205 (let ((lisp-type (convert-foreign-typed-aref-type type))) | |
206 `(locally | |
207 (declare (optimize (speed 3) (safety 0))) | |
208 (fli:foreign-typed-aref ',lisp-type ,ptr (the fixnum ,o… | |
209 form)) | |
210 | |
211 ;;; Open-code the call to FLI:DEREFERENCE when TYPE is constant at | |
212 ;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available. | |
213 #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) | |
214 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) | |
215 (if (constantp type) | |
216 (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))) | |
217 (type (convert-foreign-type (eval type)))) | |
218 `(fli:dereference ,ptr-form :type ',type)) | |
219 form)) | |
220 | |
221 (defun %mem-set (value ptr type &optional (offset 0)) | |
222 "Set the object of TYPE at OFFSET bytes from PTR." | |
223 (unless (zerop offset) | |
224 (setf ptr (inc-pointer ptr offset))) | |
225 (setf (fli:dereference ptr :type (convert-foreign-type type)) value)) | |
226 | |
227 ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use | |
228 ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET. | |
229 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) | |
230 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off… | |
231 (if (constantp type) | |
232 (once-only (val) | |
233 (let ((type (eval type))) | |
234 (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p ty… | |
235 (eql type :pointer)) | |
236 (let ((fli-type (convert-foreign-type type)) | |
237 (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,of… | |
238 `(setf (fli:dereference ,ptr-form :type ',fli-type) ,val… | |
239 (let ((lisp-type (convert-foreign-typed-aref-type type))) | |
240 `(locally | |
241 (declare (optimize (speed 3) (safety 0))) | |
242 (setf (fli:foreign-typed-aref ',lisp-type ,ptr | |
243 (the fixnum ,off)) | |
244 ,val)))))) | |
245 form)) | |
246 | |
247 ;;; Open-code the call to (SETF FLI:DEREFERENCE) when TYPE is constant | |
248 ;;; at macroexpansion time. | |
249 #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) | |
250 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off… | |
251 (if (constantp type) | |
252 (once-only (val) | |
253 (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))) | |
254 (type (convert-foreign-type (eval type)))) | |
255 `(setf (fli:dereference ,ptr-form :type ',type) ,val))) | |
256 form)) | |
257 | |
258 ;;;# Foreign Type Operations | |
259 | |
260 (defun %foreign-type-size (type) | |
261 "Return the size in bytes of a foreign type." | |
262 (fli:size-of (convert-foreign-type type))) | |
263 | |
264 (defun %foreign-type-alignment (type) | |
265 "Return the structure alignment in bytes of foreign type." | |
266 #+(and darwin harp::powerpc) | |
267 (when (eq type :double) | |
268 (return-from %foreign-type-alignment 8)) | |
269 ;; Override not necessary for the remaining types... | |
270 (fli:align-of (convert-foreign-type type))) | |
271 | |
272 ;;;# Calling Foreign Functions | |
273 | |
274 (defvar *foreign-funcallable-cache* (make-hash-table :test 'equal) | |
275 "Caches foreign funcallables created by %FOREIGN-FUNCALL or | |
276 %FOREIGN-FUNCALL-POINTER. We only need to have one per each | |
277 signature.") | |
278 | |
279 (defun foreign-funcall-type-and-args (args) | |
280 "Returns a list of types, list of args and return type." | |
281 (let ((return-type :void)) | |
282 (loop for (type arg) on args by #'cddr | |
283 if arg collect (convert-foreign-type type) into types | |
284 and collect arg into fargs | |
285 else do (setf return-type (convert-foreign-type type)) | |
286 finally (return (values types fargs return-type))))) | |
287 | |
288 (defun create-foreign-funcallable (types rettype convention) | |
289 "Creates a foreign funcallable for the signature TYPES -> RETTYPE." | |
290 #+mac (declare (ignore convention)) | |
291 (format t "~&Creating foreign funcallable for signature ~S -> ~S~%" | |
292 types rettype) | |
293 ;; yes, ugly, this most likely wants to be a top-level form... | |
294 (let ((internal-name (gensym))) | |
295 (funcall | |
296 (compile nil | |
297 `(lambda () | |
298 (fli:define-foreign-funcallable ,internal-name | |
299 ,(loop for type in types | |
300 collect (list (gensym) type)) | |
301 :result-type ,rettype | |
302 :language :ansi-c | |
303 ;; avoid warning about cdecl not being supported on m… | |
304 #-mac ,@(list :calling-convention convention))))) | |
305 internal-name)) | |
306 | |
307 (defun get-foreign-funcallable (types rettype convention) | |
308 "Returns a foreign funcallable for the signature TYPES -> RETTYPE - | |
309 either from the cache or newly created." | |
310 (let ((signature (cons rettype types))) | |
311 (or (gethash signature *foreign-funcallable-cache*) | |
312 ;; (SETF GETHASH) is supposed to be thread-safe | |
313 (setf (gethash signature *foreign-funcallable-cache*) | |
314 (create-foreign-funcallable types rettype convention))))) | |
315 | |
316 (defmacro %%foreign-funcall (foreign-function args convention) | |
317 "Does the actual work for %FOREIGN-FUNCALL-POINTER and %FOREIGN-FUNCAL… | |
318 Checks if a foreign funcallable which fits ARGS already exists and creat… | |
319 and caches it if necessary. Finally calls it." | |
320 (multiple-value-bind (types fargs rettype) | |
321 (foreign-funcall-type-and-args args) | |
322 `(funcall (load-time-value | |
323 (get-foreign-funcallable ',types ',rettype ',convention)) | |
324 ,foreign-function ,@fargs))) | |
325 | |
326 (defmacro %foreign-funcall (name args &key library convention) | |
327 "Calls a foreign function named NAME passing arguments ARGS." | |
328 `(%%foreign-funcall | |
329 (fli:make-pointer :symbol-name ,name | |
330 :module ',(if (eq library :default) nil library)) | |
331 ,args ,convention)) | |
332 | |
333 (defmacro %foreign-funcall-pointer (ptr args &key convention) | |
334 "Calls a foreign function pointed at by PTR passing arguments ARGS." | |
335 `(%%foreign-funcall ,ptr ,args ,convention)) | |
336 | |
337 (defun defcfun-helper-forms (name lisp-name rettype args types options) | |
338 "Return 2 values for DEFCFUN. A prelude form and a caller form." | |
339 (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-n… | |
340 (values | |
341 `(fli:define-foreign-function (,ff-name ,name :source) | |
342 ,(mapcar (lambda (ty) (list (gensym) (convert-foreign-type ty)… | |
343 types) | |
344 :result-type ,(convert-foreign-type rettype) | |
345 :language :ansi-c | |
346 :module ',(let ((lib (getf options :library))) | |
347 (if (eq lib :default) nil lib)) | |
348 ;; avoid warning about cdecl not being supported on mac platforms | |
349 #-mac ,@(list :calling-convention (getf options :convention))) | |
350 `(,ff-name ,@args)))) | |
351 | |
352 ;;;# Callbacks | |
353 | |
354 (defvar *callbacks* (make-hash-table)) | |
355 | |
356 ;;; Create a package to contain the symbols for callback functions. We | |
357 ;;; want to redefine callbacks with the same symbol so the internal data | |
358 ;;; structures are reused. | |
359 (defpackage #:cffi-callbacks | |
360 (:use)) | |
361 | |
362 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the inter… | |
363 ;;; callback for NAME. | |
364 (eval-when (:compile-toplevel :load-toplevel :execute) | |
365 (defun intern-callback (name) | |
366 (intern (format nil "~A::~A" | |
367 (if-let (package (symbol-package name)) | |
368 (package-name package) | |
369 "#") | |
370 (symbol-name name)) | |
371 '#:cffi-callbacks))) | |
372 | |
373 (defmacro %defcallback (name rettype arg-names arg-types body | |
374 &key convention) | |
375 (let ((cb-name (intern-callback name))) | |
376 `(progn | |
377 (fli:define-foreign-callable | |
378 (,cb-name :encode :lisp | |
379 :result-type ,(convert-foreign-type rettype) | |
380 :calling-convention ,convention | |
381 :language :ansi-c | |
382 :no-check nil) | |
383 ,(mapcar (lambda (sym type) | |
384 (list sym (convert-foreign-type type))) | |
385 arg-names arg-types) | |
386 ,body) | |
387 (setf (gethash ',name *callbacks*) ',cb-name)))) | |
388 | |
389 (defun %callback (name) | |
390 (multiple-value-bind (symbol winp) | |
391 (gethash name *callbacks*) | |
392 (unless winp | |
393 (error "Undefined callback: ~S" name)) | |
394 (fli:make-pointer :symbol-name symbol :module :callbacks))) | |
395 | |
396 ;;;# Loading Foreign Libraries | |
397 | |
398 (defun %load-foreign-library (name path) | |
399 "Load the foreign library NAME." | |
400 (fli:register-module (or name path) :connection-style :immediate | |
401 :real-name path)) | |
402 | |
403 (defun %close-foreign-library (name) | |
404 "Close the foreign library NAME." | |
405 (fli:disconnect-module name :remove t)) | |
406 | |
407 (defun native-namestring (pathname) | |
408 (namestring pathname)) | |
409 | |
410 ;;;# Foreign Globals | |
411 | |
412 (defun %foreign-symbol-pointer (name library) | |
413 "Returns a pointer to a foreign symbol NAME." | |
414 (values | |
415 (ignore-errors | |
416 (fli:make-pointer :symbol-name name :type :void | |
417 :module (if (eq library :default) nil library))))) |