cffi-ecl.lisp - clic - Clic is an command line interactive client for gopher wr… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-ecl.lisp (17282B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-ecl.lisp --- ECL backend for CFFI. | |
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 #:alexandria) | |
32 (:import-from #:si #:null-pointer-p) | |
33 (:export | |
34 #:*cffi-ecl-method* | |
35 #:canonicalize-symbol-name-case | |
36 #:foreign-pointer | |
37 #:pointerp | |
38 #:pointer-eq | |
39 #:%foreign-alloc | |
40 #:foreign-free | |
41 #:with-foreign-pointer | |
42 #:null-pointer | |
43 #:null-pointer-p | |
44 #:inc-pointer | |
45 #:make-pointer | |
46 #:pointer-address | |
47 #:%mem-ref | |
48 #:%mem-set | |
49 #:%foreign-funcall | |
50 #:%foreign-funcall-pointer | |
51 #:%foreign-funcall-varargs | |
52 #:%foreign-funcall-pointer-varargs | |
53 #:%foreign-type-alignment | |
54 #:%foreign-type-size | |
55 #:%load-foreign-library | |
56 #:%close-foreign-library | |
57 #:native-namestring | |
58 #:make-shareable-byte-vector | |
59 #:with-pointer-to-vector-data | |
60 #:%defcallback | |
61 #:%callback | |
62 #:%foreign-symbol-pointer)) | |
63 | |
64 (in-package #:cffi-sys) | |
65 | |
66 ;;; | |
67 ;;; ECL allows many ways of calling a foreign function, and also many | |
68 ;;; ways of finding the pointer associated to a function name. They | |
69 ;;; depend on whether the FFI relies on libffi or on the C/C++ compiler, | |
70 ;;; and whether they use the shared library loader to locate symbols | |
71 ;;; or they are linked by the linker. | |
72 ;;; | |
73 ;;; :DFFI | |
74 ;;; | |
75 ;;; ECL uses libffi to call foreign functions. The only way to find out | |
76 ;;; foreign symbols is by loading shared libraries and using dlopen() | |
77 ;;; or similar. | |
78 ;;; | |
79 ;;; :DLOPEN | |
80 ;;; | |
81 ;;; ECL compiles FFI code as C/C++ statements. The names are resolved | |
82 ;;; at run time by the shared library loader every time the function | |
83 ;;; is called | |
84 ;;; | |
85 ;;; :C/C++ | |
86 ;;; | |
87 ;;; ECL compiles FFI code as C/C++ statements, but the name resolution | |
88 ;;; happens at link time. In this case you have to tell the ECL | |
89 ;;; compiler which are the right ld-flags (c:*ld-flags*) to link in | |
90 ;;; the library. | |
91 ;;; | |
92 (defvar *cffi-ecl-method* | |
93 #+dffi :dffi | |
94 #+(and dlopen (not dffi)) :dlopen | |
95 #-(or dffi dlopen) :c/c++ | |
96 "The type of code that CFFI generates for ECL: :DFFI when using the | |
97 dynamical foreign function interface; :DLOPEN when using C code and | |
98 dynamical references to symbols; :C/C++ for C/C++ code with static | |
99 references to symbols.") | |
100 | |
101 ;;;# Mis-features | |
102 | |
103 #-long-long | |
104 (pushnew 'no-long-long *features*) | |
105 (pushnew 'flat-namespace *features*) | |
106 | |
107 ;;;# Symbol Case | |
108 | |
109 (defun canonicalize-symbol-name-case (name) | |
110 (declare (string name)) | |
111 (string-upcase name)) | |
112 | |
113 ;;;# Allocation | |
114 | |
115 (defun %foreign-alloc (size) | |
116 "Allocate SIZE bytes of foreign-addressable memory." | |
117 (si:allocate-foreign-data :void size)) | |
118 | |
119 (defun foreign-free (ptr) | |
120 "Free a pointer PTR allocated by FOREIGN-ALLOC." | |
121 (si:free-foreign-data ptr)) | |
122 | |
123 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
124 "Bind VAR to SIZE bytes of foreign memory during BODY. The | |
125 pointer in VAR is invalid beyond the dynamic extent of BODY, and | |
126 may be stack-allocated if supported by the implementation. If | |
127 SIZE-VAR is supplied, it will be bound to SIZE during BODY." | |
128 (unless size-var | |
129 (setf size-var (gensym "SIZE"))) | |
130 `(let* ((,size-var ,size) | |
131 (,var (%foreign-alloc ,size-var))) | |
132 (unwind-protect | |
133 (progn ,@body) | |
134 (foreign-free ,var)))) | |
135 | |
136 ;;;# Misc. Pointer Operations | |
137 | |
138 (deftype foreign-pointer () | |
139 'si:foreign-data) | |
140 | |
141 (defun null-pointer () | |
142 "Construct and return a null pointer." | |
143 (si:allocate-foreign-data :void 0)) | |
144 | |
145 (defun inc-pointer (ptr offset) | |
146 "Return a pointer OFFSET bytes past PTR." | |
147 (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void)) | |
148 | |
149 (defun pointerp (ptr) | |
150 "Return true if PTR is a foreign pointer." | |
151 (typep ptr 'si:foreign-data)) | |
152 | |
153 (defun pointer-eq (ptr1 ptr2) | |
154 "Return true if PTR1 and PTR2 point to the same address." | |
155 (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2))) | |
156 | |
157 (defun make-pointer (address) | |
158 "Return a pointer pointing to ADDRESS." | |
159 (ffi:make-pointer address :void)) | |
160 | |
161 (defun pointer-address (ptr) | |
162 "Return the address pointed to by PTR." | |
163 (ffi:pointer-address ptr)) | |
164 | |
165 ;;;# Shareable Vectors | |
166 ;;; | |
167 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA | |
168 ;;; should be defined to perform a copy-in/copy-out if the Lisp | |
169 ;;; implementation can't do this. | |
170 | |
171 (defun make-shareable-byte-vector (size) | |
172 "Create a Lisp vector of SIZE bytes that can passed to | |
173 WITH-POINTER-TO-VECTOR-DATA." | |
174 (make-array size :element-type '(unsigned-byte 8))) | |
175 | |
176 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) | |
177 "Bind PTR-VAR to a foreign pointer to the data in VECTOR." | |
178 `(let ((,ptr-var (si:make-foreign-data-from-array ,vector))) | |
179 ,@body)) | |
180 | |
181 ;;;# Type Operations | |
182 | |
183 (defconstant +translation-table+ | |
184 '((:char :byte "char") | |
185 (:unsigned-char :unsigned-byte "unsigned char") | |
186 (:short :short "short") | |
187 (:unsigned-short :unsigned-short "unsigned short") | |
188 (:int :int "int") | |
189 (:unsigned-int :unsigned-int "unsigned int") | |
190 (:long :long "long") | |
191 (:unsigned-long :unsigned-long "unsigned long") | |
192 #+long-long | |
193 (:long-long :long-long "long long") | |
194 #+long-long | |
195 (:unsigned-long-long :unsigned-long-long "unsigned long long") | |
196 (:float :float "float") | |
197 (:double :double "double") | |
198 (:pointer :pointer-void "void*") | |
199 (:void :void "void"))) | |
200 | |
201 (defun cffi-type->ecl-type (type-keyword) | |
202 "Convert a CFFI type keyword to an ECL type keyword." | |
203 (or (second (find type-keyword +translation-table+ :key #'first)) | |
204 (error "~S is not a valid CFFI type" type-keyword))) | |
205 | |
206 (defun ecl-type->c-type (type-keyword) | |
207 "Convert a CFFI type keyword to an valid C type keyword." | |
208 (or (third (find type-keyword +translation-table+ :key #'second)) | |
209 (error "~S is not a valid CFFI type" type-keyword))) | |
210 | |
211 (defun %foreign-type-size (type-keyword) | |
212 "Return the size in bytes of a foreign type." | |
213 (nth-value 0 (ffi:size-of-foreign-type | |
214 (cffi-type->ecl-type type-keyword)))) | |
215 | |
216 (defun %foreign-type-alignment (type-keyword) | |
217 "Return the alignment in bytes of a foreign type." | |
218 (nth-value 1 (ffi:size-of-foreign-type | |
219 (cffi-type->ecl-type type-keyword)))) | |
220 | |
221 ;;;# Dereferencing | |
222 | |
223 (defun %mem-ref (ptr type &optional (offset 0)) | |
224 "Dereference an object of TYPE at OFFSET bytes from PTR." | |
225 (let* ((type (cffi-type->ecl-type type)) | |
226 (type-size (ffi:size-of-foreign-type type))) | |
227 (si:foreign-data-ref-elt | |
228 (si:foreign-data-recast ptr (+ offset type-size) :void) offset type… | |
229 | |
230 (defun %mem-set (value ptr type &optional (offset 0)) | |
231 "Set an object of TYPE at OFFSET bytes from PTR." | |
232 (let* ((type (cffi-type->ecl-type type)) | |
233 (type-size (ffi:size-of-foreign-type type))) | |
234 (si:foreign-data-set-elt | |
235 (si:foreign-data-recast ptr (+ offset type-size) :void) | |
236 offset type value))) | |
237 | |
238 ;;; Inline versions that use C expressions instead of function calls. | |
239 | |
240 (defparameter +mem-ref-strings+ | |
241 (loop for (cffi-type ecl-type c-string) in +translation-table+ | |
242 for string = (format nil "*((~A *)(((char*)#0)+#1))" c-string) | |
243 collect (list cffi-type ecl-type string))) | |
244 | |
245 (defparameter +mem-set-strings+ | |
246 (loop for (cffi-type ecl-type c-string) in +translation-table+ | |
247 for string = (format nil "*((~A *)(((char*)#0)+#1))=#2" c-string) | |
248 collect (list cffi-type ecl-type string))) | |
249 | |
250 (define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset… | |
251 (if (and (constantp type) (constantp offset)) | |
252 (let ((record (assoc (eval type) +mem-ref-strings+))) | |
253 `(ffi:c-inline (,ptr ,offset) | |
254 (:pointer-void :cl-index) ; argument types | |
255 ,(second record) ; return type | |
256 ,(third record) ; the precomputed expansion | |
257 :one-liner t)) | |
258 whole)) | |
259 | |
260 (define-compiler-macro %mem-set (&whole whole value ptr type &optional (… | |
261 (if (and (constantp type) (constantp offset)) | |
262 (let ((record (assoc (eval type) +mem-set-strings+))) | |
263 `(ffi:c-inline (,ptr ,offset ,value) ; arguments with type trans… | |
264 (:pointer-void :cl-index ,(second record)) | |
265 :void ; does not return anything | |
266 ,(third record) ; precomputed expansion | |
267 :one-liner t)) | |
268 whole)) | |
269 | |
270 ;;;# Calling Foreign Functions | |
271 | |
272 (defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,… | |
273 | |
274 (defun c-inline-function-call (thing fixed-types types values return-typ… | |
275 (when dynamic-call | |
276 (when (stringp thing) | |
277 (setf thing `(%foreign-symbol-pointer ,thing nil))) | |
278 (push thing values) | |
279 (push :pointer-void types)) | |
280 (let* ((decl-args | |
281 (format nil "~{~A~^, ~}~A" | |
282 (mapcar #'ecl-type->c-type fixed-types) (if (null vari… | |
283 (call-args | |
284 (if dynamic-call | |
285 ;; #0 is already used in a cast (it is a function pointer) | |
286 (subseq +ecl-inline-codes+ 3 (max 3 (1- (* (length values)… | |
287 ;; #0 is not used, so we start from the beginning | |
288 (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values)… | |
289 (clines | |
290 (if dynamic-call | |
291 nil | |
292 (format nil "extern ~A ~A(~A);" | |
293 (ecl-type->c-type return-type) thing decl-args))) | |
294 (call-code | |
295 (if dynamic-call | |
296 (format nil "((~A (*)(~A))(#0))(~A)" | |
297 (ecl-type->c-type return-type) decl-args call-args) | |
298 (format nil "~A(~A)" thing call-args)))) | |
299 `(progn | |
300 (ffi:clines ,@(ensure-list clines)) | |
301 (ffi:c-inline ,values ,types ,return-type ,call-code :one-liner t… | |
302 | |
303 (defun dffi-function-pointer-call (pointer types values return-type) | |
304 (when (stringp pointer) | |
305 (setf pointer `(%foreign-symbol-pointer ,pointer nil))) | |
306 #-dffi | |
307 `(error "In interpreted code, attempted to call a foreign function~% ~… | |
308 but ECL was built without support for that." ,pointer) | |
309 #+dffi | |
310 `(si::call-cfun ,pointer ,return-type (list ,@types) (list ,@values))) | |
311 | |
312 (defun foreign-funcall-parse-args (args) | |
313 "Return three values, lists of arg types, values, and result type." | |
314 (let ((return-type :void)) | |
315 (loop for (type arg) on args by #'cddr | |
316 if arg collect (cffi-type->ecl-type type) into types | |
317 and collect arg into values | |
318 else do (setf return-type (cffi-type->ecl-type type)) | |
319 finally (return (values types values return-type))))) | |
320 | |
321 (defmacro %foreign-funcall (name args &key library convention) | |
322 "Call a foreign function." | |
323 (declare (ignore library convention)) | |
324 (multiple-value-bind (types values return-type) | |
325 (foreign-funcall-parse-args args) | |
326 `(ext:with-backend | |
327 :bytecodes | |
328 ,(dffi-function-pointer-call name types values return-type) | |
329 :c/c++ | |
330 ,(ecase *cffi-ecl-method* | |
331 (:dffi (dffi-function-pointer-call name types values return-t… | |
332 (:dlopen (c-inline-function-call name types types values return… | |
333 (:c/c++ (c-inline-function-call name types types values return… | |
334 | |
335 (defmacro %foreign-funcall-pointer (pointer args &key convention) | |
336 "Funcall a pointer to a foreign function." | |
337 (declare (ignore convention)) | |
338 (multiple-value-bind (types values return-type) | |
339 (foreign-funcall-parse-args args) | |
340 `(ext:with-backend | |
341 :bytecodes | |
342 ,(dffi-function-pointer-call pointer types values return-type) | |
343 :c/c++ | |
344 ,(if (eq *cffi-ecl-method* :dffi) | |
345 (dffi-function-pointer-call pointer types values return-type) | |
346 (c-inline-function-call pointer types types values return-typ… | |
347 | |
348 (defmacro %foreign-funcall-varargs (name args varargs &key library conve… | |
349 (declare (ignore library convention)) | |
350 (multiple-value-bind (fixed-types fixed-values) | |
351 (foreign-funcall-parse-args args) | |
352 (multiple-value-bind (varargs-types varargs-values return-type) | |
353 (foreign-funcall-parse-args varargs) | |
354 (let ((all-types (append fixed-types varargs-types)) | |
355 (values (append fixed-values varargs-values))) | |
356 `(ext:with-backend | |
357 :bytecodes | |
358 ,(dffi-function-pointer-call name all-types values return-type) | |
359 :c/c++ | |
360 ,(ecase *cffi-ecl-method* | |
361 (:dffi (dffi-function-pointer-call name all-types values r… | |
362 (:dlopen (c-inline-function-call name fixed-types all-types … | |
363 (:c/c++ (c-inline-function-call name fixed-types all-types … | |
364 | |
365 (defmacro %foreign-funcall-pointer-varargs (pointer args varargs &key co… | |
366 (declare (ignore convention)) | |
367 (multiple-value-bind (fixed-types fixed-values) | |
368 (foreign-funcall-parse-args args) | |
369 (multiple-value-bind (varargs-types varargs-values return-type) | |
370 (foreign-funcall-parse-args varargs) | |
371 (let ((all-types (append fixed-types varargs-types)) | |
372 (values (append fixed-values varargs-values))) | |
373 `(ext:with-backend | |
374 :bytecodes | |
375 ,(dffi-function-pointer-call pointer all-types values return-ty… | |
376 :c/c++ | |
377 ,(if (eq *cffi-ecl-method* :dffi) | |
378 (dffi-function-pointer-call pointer all-types values return-… | |
379 (c-inline-function-call pointer fixed-types all-types values… | |
380 | |
381 ;;;# Foreign Libraries | |
382 | |
383 (defun %load-foreign-library (name path) | |
384 "Load a foreign library." | |
385 (declare (ignore name)) | |
386 #-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~ | |
387 FFI:LOAD-FOREIGN-LIBRARY with a constant argument inste… | |
388 #+dffi | |
389 (handler-case (si:load-foreign-module path) | |
390 (file-error () | |
391 (error "file error while trying to load `~A'" path)))) | |
392 | |
393 (defun %close-foreign-library (handle) | |
394 "Close a foreign library." | |
395 (handler-case (si::unload-foreign-module handle) | |
396 (undefined-function () | |
397 (restart-case (error "Detected ECL prior to version 15.2.21. ~ | |
398 Function CFFI:CLOSE-FOREIGN-LIBRARY isn't im… | |
399 (ignore () :report "Continue anyway (foreign library will remain… | |
400 | |
401 (defun native-namestring (pathname) | |
402 (namestring pathname)) | |
403 | |
404 ;;;# Callbacks | |
405 | |
406 ;;; Create a package to contain the symbols for callback functions. | |
407 ;;; We want to redefine callbacks with the same symbol so the internal | |
408 ;;; data structures are reused. | |
409 (defpackage #:cffi-callbacks | |
410 (:use)) | |
411 | |
412 (defvar *callbacks* (make-hash-table)) | |
413 | |
414 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the | |
415 ;;; internal callback for NAME. | |
416 (eval-when (:compile-toplevel :load-toplevel :execute) | |
417 (defun intern-callback (name) | |
418 (intern (format nil "~A::~A" | |
419 (if-let (package (symbol-package name)) | |
420 (package-name package) | |
421 "#") | |
422 (symbol-name name)) | |
423 '#:cffi-callbacks))) | |
424 | |
425 (defmacro %defcallback (name rettype arg-names arg-types body | |
426 &key convention) | |
427 (declare (ignore convention)) | |
428 (let ((cb-name (intern-callback name)) | |
429 (cb-type #.(if (> ext:+ecl-version-number+ 160102) | |
430 :default :cdecl))) | |
431 `(progn | |
432 (ffi:defcallback (,cb-name ,cb-type) | |
433 ,(cffi-type->ecl-type rettype) | |
434 ,(mapcar #'list arg-names | |
435 (mapcar #'cffi-type->ecl-type arg-types)) | |
436 ,body) | |
437 (setf (gethash ',name *callbacks*) ',cb-name)))) | |
438 | |
439 (defun %callback (name) | |
440 (multiple-value-bind (symbol winp) | |
441 (gethash name *callbacks*) | |
442 (unless winp | |
443 (error "Undefined callback: ~S" name)) | |
444 (ffi:callback symbol))) | |
445 | |
446 ;;;# Foreign Globals | |
447 | |
448 (defun %foreign-symbol-pointer (name library) | |
449 "Returns a pointer to a foreign symbol NAME." | |
450 (declare (ignore library)) | |
451 (handler-case | |
452 (si:find-foreign-symbol (coerce name 'base-string) | |
453 :default :pointer-void 0) | |
454 (error (c) nil))) |