cffi-allegro.lisp - clic - Clic is an command line interactive client for gophe… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-allegro.lisp (16300B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL. | |
4 ;;; | |
5 ;;; Copyright (C) 2005-2009, Luis Oliveira <loliveira(@)common-lisp.net> | |
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) | |
32 (:import-from #:alexandria #:if-let #:with-unique-names #:once-only) | |
33 (:export | |
34 #:canonicalize-symbol-name-case | |
35 #:foreign-pointer | |
36 #:pointerp | |
37 #:pointer-eq | |
38 #:null-pointer | |
39 #:null-pointer-p | |
40 #:inc-pointer | |
41 #:make-pointer | |
42 #:pointer-address | |
43 #:%foreign-alloc | |
44 #:foreign-free | |
45 #:with-foreign-pointer | |
46 #:%foreign-funcall | |
47 #:%foreign-funcall-pointer | |
48 #:%foreign-type-alignment | |
49 #:%foreign-type-size | |
50 #:%load-foreign-library | |
51 #:%close-foreign-library | |
52 #:native-namestring | |
53 #:%mem-ref | |
54 #:%mem-set | |
55 #:make-shareable-byte-vector | |
56 #:with-pointer-to-vector-data | |
57 #:%foreign-symbol-pointer | |
58 #:defcfun-helper-forms | |
59 #:%defcallback | |
60 #:%callback)) | |
61 | |
62 (in-package #:cffi-sys) | |
63 | |
64 ;;;# Mis-features | |
65 | |
66 #-64bit (pushnew 'no-long-long *features*) | |
67 (pushnew 'flat-namespace *features*) | |
68 | |
69 ;;;# Symbol Case | |
70 | |
71 (defun canonicalize-symbol-name-case (name) | |
72 (declare (string name)) | |
73 (if (eq excl:*current-case-mode* :case-sensitive-lower) | |
74 (string-downcase name) | |
75 (string-upcase name))) | |
76 | |
77 ;;;# Basic Pointer Operations | |
78 | |
79 (deftype foreign-pointer () | |
80 'ff:foreign-address) | |
81 | |
82 (defun pointerp (ptr) | |
83 "Return true if PTR is a foreign pointer." | |
84 (ff:foreign-address-p ptr)) | |
85 | |
86 (defun pointer-eq (ptr1 ptr2) | |
87 "Return true if PTR1 and PTR2 point to the same address." | |
88 (eql ptr1 ptr2)) | |
89 | |
90 (defun null-pointer () | |
91 "Return a null pointer." | |
92 0) | |
93 | |
94 (defun null-pointer-p (ptr) | |
95 "Return true if PTR is a null pointer." | |
96 (zerop ptr)) | |
97 | |
98 (defun inc-pointer (ptr offset) | |
99 "Return a pointer pointing OFFSET bytes past PTR." | |
100 (+ ptr offset)) | |
101 | |
102 (defun make-pointer (address) | |
103 "Return a pointer pointing to ADDRESS." | |
104 (check-type address ff:foreign-address) | |
105 address) | |
106 | |
107 (defun pointer-address (ptr) | |
108 "Return the address pointed to by PTR." | |
109 (check-type ptr ff:foreign-address) | |
110 ptr) | |
111 | |
112 ;;;# Allocation | |
113 ;;; | |
114 ;;; Functions and macros for allocating foreign memory on the stack | |
115 ;;; and on the heap. The main CFFI package defines macros that wrap | |
116 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage | |
117 ;;; when the memory has dynamic extent. | |
118 | |
119 (defun %foreign-alloc (size) | |
120 "Allocate SIZE bytes on the heap and return a pointer." | |
121 (ff:allocate-fobject :char :c size)) | |
122 | |
123 (defun foreign-free (ptr) | |
124 "Free a PTR allocated by FOREIGN-ALLOC." | |
125 (ff:free-fobject ptr)) | |
126 | |
127 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
128 "Bind VAR to SIZE bytes of foreign memory during BODY. The | |
129 pointer in VAR is invalid beyond the dynamic extent of BODY, and | |
130 may be stack-allocated if supported by the implementation. If | |
131 SIZE-VAR is supplied, it will be bound to SIZE during BODY." | |
132 (unless size-var | |
133 (setf size-var (gensym "SIZE"))) | |
134 #+(version>= 8 1) | |
135 (when (and (constantp size) (<= (eval size) ff:*max-stack-fobject-byte… | |
136 (return-from with-foreign-pointer | |
137 `(let ((,size-var ,(eval size))) | |
138 (declare (ignorable ,size-var)) | |
139 (ff:with-static-fobject (,var '(:array :char ,(eval size)) | |
140 :allocation :foreign-static-gc) | |
141 ;; (excl::stack-allocated-p var) => T | |
142 (let ((,var (ff:fslot-address ,var))) | |
143 ,@body))))) | |
144 `(let* ((,size-var ,size) | |
145 (,var (ff:allocate-fobject :char :c ,size-var))) | |
146 (unwind-protect | |
147 (progn ,@body) | |
148 (ff:free-fobject ,var)))) | |
149 | |
150 ;;;# Shareable Vectors | |
151 ;;; | |
152 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA | |
153 ;;; should be defined to perform a copy-in/copy-out if the Lisp | |
154 ;;; implementation can't do this. | |
155 | |
156 (defun make-shareable-byte-vector (size) | |
157 "Create a Lisp vector of SIZE bytes can passed to | |
158 WITH-POINTER-TO-VECTOR-DATA." | |
159 (make-array size :element-type '(unsigned-byte 8) | |
160 :allocation :static-reclaimable)) | |
161 | |
162 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) | |
163 "Bind PTR-VAR to a foreign pointer to the data in VECTOR." | |
164 ;; An array allocated in static-reclamable is a non-simple array in | |
165 ;; the normal Lisp allocation area, pointing to a simple array in | |
166 ;; the static-reclaimable allocation area. Therefore we have to get | |
167 ;; out the simple-array to find the pointer to the actual contents. | |
168 (with-unique-names (simple-vec) | |
169 `(excl:with-underlying-simple-vector (,vector ,simple-vec) | |
170 (let ((,ptr-var (ff:fslot-address-typed :unsigned-char :lisp | |
171 ,simple-vec))) | |
172 ,@body)))) | |
173 | |
174 ;;;# Dereferencing | |
175 | |
176 (defun convert-foreign-type (type-keyword) | |
177 "Convert a CFFI type keyword to an Allegro type." | |
178 (ecase type-keyword | |
179 (:char :char) | |
180 (:unsigned-char :unsigned-char) | |
181 (:short :short) | |
182 (:unsigned-short :unsigned-short) | |
183 (:int :int) | |
184 (:unsigned-int :unsigned-int) | |
185 (:long :long) | |
186 (:unsigned-long :unsigned-long) | |
187 (:long-long | |
188 #+64bit :nat | |
189 #-64bit (error "this platform does not support :long-long.")) | |
190 (:unsigned-long-long | |
191 #+64bit :unsigned-nat | |
192 #-64bit (error "this platform does not support :unsigned-long-long"… | |
193 (:float :float) | |
194 (:double :double) | |
195 (:pointer :unsigned-nat) | |
196 (:void :void))) | |
197 | |
198 (defun %mem-ref (ptr type &optional (offset 0)) | |
199 "Dereference an object of TYPE at OFFSET bytes from PTR." | |
200 (unless (zerop offset) | |
201 (setf ptr (inc-pointer ptr offset))) | |
202 (ff:fslot-value-typed (convert-foreign-type type) :c ptr)) | |
203 | |
204 ;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the | |
205 ;;; CFFI type is constant. Allegro does its own transformation on the | |
206 ;;; call that results in efficient code. | |
207 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) | |
208 (if (constantp type) | |
209 (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) | |
210 `(ff:fslot-value-typed ',(convert-foreign-type (eval type)) | |
211 :c ,ptr-form)) | |
212 form)) | |
213 | |
214 (defun %mem-set (value ptr type &optional (offset 0)) | |
215 "Set the object of TYPE at OFFSET bytes from PTR." | |
216 (unless (zerop offset) | |
217 (setf ptr (inc-pointer ptr offset))) | |
218 (setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value)) | |
219 | |
220 ;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED) | |
221 ;;; when the CFFI type is constant. Allegro does its own | |
222 ;;; transformation on the call that results in efficient code. | |
223 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off… | |
224 (if (constantp type) | |
225 (once-only (val) | |
226 (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) | |
227 `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval typ… | |
228 :c ,ptr-form) ,val))) | |
229 form)) | |
230 | |
231 ;;;# Calling Foreign Functions | |
232 | |
233 (defun %foreign-type-size (type-keyword) | |
234 "Return the size in bytes of a foreign type." | |
235 (ff:sizeof-fobject (convert-foreign-type type-keyword))) | |
236 | |
237 (defun %foreign-type-alignment (type-keyword) | |
238 "Returns the alignment in bytes of a foreign type." | |
239 #+(and powerpc macosx32) | |
240 (when (eq type-keyword :double) | |
241 (return-from %foreign-type-alignment 8)) | |
242 ;; No override necessary for the remaining types.... | |
243 (ff::sized-ftype-prim-align | |
244 (ff::iforeign-type-sftype | |
245 (ff:get-foreign-type | |
246 (convert-foreign-type type-keyword))))) | |
247 | |
248 (defun foreign-funcall-type-and-args (args) | |
249 "Returns a list of types, list of args and return type." | |
250 (let ((return-type :void)) | |
251 (loop for (type arg) on args by #'cddr | |
252 if arg collect type into types | |
253 and collect arg into fargs | |
254 else do (setf return-type type) | |
255 finally (return (values types fargs return-type))))) | |
256 | |
257 (defun convert-to-lisp-type (type) | |
258 (ecase type | |
259 ((:char :short :int :long :nat) | |
260 `(signed-byte ,(* 8 (ff:sizeof-fobject type)))) | |
261 ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsig… | |
262 `(unsigned-byte ,(* 8 (ff:sizeof-fobject type)))) | |
263 (:float 'single-float) | |
264 (:double 'double-float) | |
265 (:void 'null))) | |
266 | |
267 (defun allegro-type-pair (cffi-type) | |
268 ;; the :FOREIGN-ADDRESS pseudo-type accepts both pointers and | |
269 ;; arrays. We need the latter for shareable byte vector support. | |
270 (if (eq cffi-type :pointer) | |
271 (list :foreign-address) | |
272 (let ((ftype (convert-foreign-type cffi-type))) | |
273 (list ftype (convert-to-lisp-type ftype))))) | |
274 | |
275 #+ignore | |
276 (defun note-named-foreign-function (symbol name types rettype) | |
277 "Give Allegro's compiler a hint to perform a direct call." | |
278 `(eval-when (:compile-toplevel :load-toplevel :execute) | |
279 (setf (get ',symbol 'system::direct-ff-call) | |
280 (list '(,name :language :c) | |
281 t ; callback | |
282 :c ; convention | |
283 ;; return type '(:c-type lisp-type) | |
284 ',(allegro-type-pair rettype) | |
285 ;; arg types '({(:c-type lisp-type)}*) | |
286 '(,@(mapcar #'allegro-type-pair types)) | |
287 nil ; arg-checking | |
288 ff::ep-flag-never-release)))) | |
289 | |
290 (defmacro %foreign-funcall (name args &key convention library) | |
291 (declare (ignore convention library)) | |
292 (multiple-value-bind (types fargs rettype) | |
293 (foreign-funcall-type-and-args args) | |
294 `(system::ff-funcall | |
295 (load-time-value (excl::determine-foreign-address | |
296 '(,name :language :c) | |
297 #-(version>= 8 1) ff::ep-flag-never-release | |
298 #+(version>= 8 1) ff::ep-flag-always-release | |
299 nil ; method-index | |
300 )) | |
301 ;; arg types {'(:c-type lisp-type) argN}* | |
302 ,@(mapcan (lambda (type arg) | |
303 `(',(allegro-type-pair type) ,arg)) | |
304 types fargs) | |
305 ;; return type '(:c-type lisp-type) | |
306 ',(allegro-type-pair rettype)))) | |
307 | |
308 (defun defcfun-helper-forms (name lisp-name rettype args types options) | |
309 "Return 2 values for DEFCFUN. A prelude form and a caller form." | |
310 (declare (ignore options)) | |
311 (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-na… | |
312 (values | |
313 `(ff:def-foreign-call (,ff-name ,name) | |
314 ,(loop for type in types | |
315 collect (list* (gensym) (allegro-type-pair type))) | |
316 :returning ,(allegro-type-pair rettype) | |
317 ;; Don't use call-direct when there are no arguments. | |
318 ,@(unless (null args) '(:call-direct t)) | |
319 :arg-checking nil | |
320 :strings-convert nil | |
321 #+(version>= 8 1) ,@'(:release-heap :when-ok | |
322 :release-heap-ignorable t) | |
323 #+smp ,@'(:release-heap-implies-allow-gc t)) | |
324 `(,ff-name ,@args)))) | |
325 | |
326 ;;; See doc/allegro-internals.txt for a clue about entry-vec. | |
327 (defmacro %foreign-funcall-pointer (ptr args &key convention) | |
328 (declare (ignore convention)) | |
329 (multiple-value-bind (types fargs rettype) | |
330 (foreign-funcall-type-and-args args) | |
331 (with-unique-names (entry-vec) | |
332 `(let ((,entry-vec (excl::make-entry-vec-boa))) | |
333 (setf (aref ,entry-vec 1) ,ptr) ; set jump address | |
334 (system::ff-funcall | |
335 ,entry-vec | |
336 ;; arg types {'(:c-type lisp-type) argN}* | |
337 ,@(mapcan (lambda (type arg) | |
338 `(',(allegro-type-pair type) ,arg)) | |
339 types fargs) | |
340 ;; return type '(:c-type lisp-type) | |
341 ',(allegro-type-pair rettype)))))) | |
342 | |
343 ;;;# Callbacks | |
344 | |
345 ;;; The *CALLBACKS* hash table contains information about a callback | |
346 ;;; for the Allegro FFI. The key is the name of the CFFI callback, | |
347 ;;; and the value is a cons, the car containing the symbol the | |
348 ;;; callback was defined on in the CFFI-CALLBACKS package, the cdr | |
349 ;;; being an Allegro FFI pointer (a fixnum) that can be passed to C | |
350 ;;; functions. | |
351 ;;; | |
352 ;;; These pointers must be restored when a saved Lisp image is loaded. | |
353 ;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to | |
354 ;;; re-register the callbacks during Lisp startup. | |
355 (defvar *callbacks* (make-hash-table)) | |
356 | |
357 ;;; Register a callback in the *CALLBACKS* hash table. | |
358 (defun register-callback (cffi-name callback-name) | |
359 (setf (gethash cffi-name *callbacks*) | |
360 (cons callback-name (ff:register-foreign-callable | |
361 callback-name :reuse t)))) | |
362 | |
363 ;;; Restore the saved pointers in *CALLBACKS* when loading an image. | |
364 (defun restore-callbacks () | |
365 (maphash (lambda (key value) | |
366 (register-callback key (car value))) | |
367 *callbacks*)) | |
368 | |
369 ;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing | |
370 ;;; CFFI is restarted. | |
371 (eval-when (:load-toplevel :execute) | |
372 (pushnew 'restore-callbacks excl:*restart-actions*)) | |
373 | |
374 ;;; Create a package to contain the symbols for callback functions. | |
375 (defpackage #:cffi-callbacks | |
376 (:use)) | |
377 | |
378 (defun intern-callback (name) | |
379 (intern (format nil "~A::~A" | |
380 (if-let (package (symbol-package name)) | |
381 (package-name package) | |
382 "#") | |
383 (symbol-name name)) | |
384 '#:cffi-callbacks)) | |
385 | |
386 (defun convert-calling-convention (convention) | |
387 (ecase convention | |
388 (:cdecl :c) | |
389 (:stdcall :stdcall))) | |
390 | |
391 (defmacro %defcallback (name rettype arg-names arg-types body | |
392 &key convention) | |
393 (declare (ignore rettype)) | |
394 (let ((cb-name (intern-callback name))) | |
395 `(progn | |
396 (ff:defun-foreign-callable ,cb-name | |
397 ,(mapcar (lambda (sym type) (list sym (convert-foreign-type t… | |
398 arg-names arg-types) | |
399 (declare (:convention ,(convert-calling-convention convention))) | |
400 ,body) | |
401 (register-callback ',name ',cb-name)))) | |
402 | |
403 ;;; Return the saved Lisp callback pointer from *CALLBACKS* for the | |
404 ;;; CFFI callback named NAME. | |
405 (defun %callback (name) | |
406 (or (cdr (gethash name *callbacks*)) | |
407 (error "Undefined callback: ~S" name))) | |
408 | |
409 ;;;# Loading and Closing Foreign Libraries | |
410 | |
411 (defun %load-foreign-library (name path) | |
412 "Load a foreign library." | |
413 ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load | |
414 ;; the argument. However, previous versions do not and will only | |
415 ;; foreign load the argument if its type is a member of the | |
416 ;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special | |
417 ;; to a list containing whatever type NAME has. | |
418 (declare (ignore name)) | |
419 (let ((excl::*load-foreign-types* | |
420 (list (pathname-type (parse-namestring path))))) | |
421 (handler-case | |
422 (progn | |
423 #+(version>= 7) (load path :foreign t) | |
424 #-(version>= 7) (load path)) | |
425 (file-error (fe) | |
426 (error (change-class fe 'simple-error)))) | |
427 path)) | |
428 | |
429 (defun %close-foreign-library (name) | |
430 "Close the foreign library NAME." | |
431 (ff:unload-foreign-library name)) | |
432 | |
433 (defun native-namestring (pathname) | |
434 (namestring pathname)) | |
435 | |
436 ;;;# Foreign Globals | |
437 | |
438 (defun convert-external-name (name) | |
439 "Add an underscore to NAME if necessary for the ABI." | |
440 #+macosx (concatenate 'string "_" name) | |
441 #-macosx name) | |
442 | |
443 (defun %foreign-symbol-pointer (name library) | |
444 "Returns a pointer to a foreign symbol NAME." | |
445 (declare (ignore library)) | |
446 (prog1 (ff:get-entry-point (convert-external-name name)))) |