cffi-ecl.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-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 <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 #: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 0))
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 (offset 0))
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 translated
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,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
273
274 (defun c-inline-function-call (thing fixed-types types values return-type dynamic-call variadic)
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 variadic) "" ", ...")))
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) 3))))
287 ;; #0 is not used, so we start from the beginning
288 (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3))))))
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 :side-effects 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~% ~A~%~
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-type))
332 (:dlopen (c-inline-function-call name types types values return-type t nil))
333 (:c/c++ (c-inline-function-call name types types values return-type nil nil))))))
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-type t nil)))))
347
348 (defmacro %foreign-funcall-varargs (name args varargs &key library convention)
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 return-type))
362 (:dlopen (c-inline-function-call name fixed-types all-types values return-type t t))
363 (:c/c++ (c-inline-function-call name fixed-types all-types values return-type nil t))))))))
364
365 (defmacro %foreign-funcall-pointer-varargs (pointer args varargs &key convention)
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-type)
376 :c/c++
377 ,(if (eq *cffi-ecl-method* :dffi)
378 (dffi-function-pointer-call pointer all-types values return-type)
379 (c-inline-function-call pointer fixed-types all-types values return-type t t)))))))
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 instead.")
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 implemented yet.")
399 (ignore () :report "Continue anyway (foreign library will remain opened).")))))
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)))