cffi-allegro.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-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-bytes*))
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 0))
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 type))
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 :unsigned-nat)
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-name))))
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 type)))
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))))