(clear-info :variable :constant-value lisp-name)
(setf (info :variable :alien-info lisp-name)
(make-heap-alien-info :type type
- :sap-form `(foreign-symbol-address
- ',alien-name)))))
+ :sap-form `(foreign-symbol-address ',alien-name t)))))
(defmacro extern-alien (name type &environment env)
#!+sb-doc
"Access the alien variable named NAME, assuming it is of type TYPE. This
is SETFable."
- (let ((alien-name (etypecase name
- (symbol (guess-alien-name-from-lisp-name name))
- (string name))))
+ (let* ((alien-name (etypecase name
+ (symbol (guess-alien-name-from-lisp-name name))
+ (string name)))
+ (alien-type (parse-alien-type type env))
+ (datap (not (alien-fun-type-p alien-type))))
`(%heap-alien ',(make-heap-alien-info
- :type (parse-alien-type type env)
- :sap-form `(foreign-symbol-address ',alien-name)))))
+ :type alien-type
+ :sap-form `(foreign-symbol-address ',alien-name ,datap)))))
(defmacro with-alien (bindings &body body &environment env)
#!+sb-doc
(symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
binding
(/show symbol type opt1 opt2)
- (let ((alien-type (parse-alien-type type env)))
+ (let* ((alien-type (parse-alien-type type env))
+ (datap (not (alien-fun-type-p alien-type))))
(/show alien-type)
(multiple-value-bind (allocation initial-value)
(if opt2p
`((setq ,symbol ,initial-value)))
,@body)))))
(:extern
- (/show ":EXTERN case")
+ (/show0 ":EXTERN case")
(let ((info (make-heap-alien-info
:type alien-type
:sap-form `(foreign-symbol-address
- ',initial-value))))
+ ',initial-value
+ ,datap))))
`((symbol-macrolet
((,symbol (%heap-alien ',info)))
,@body))))
(:local
- (/show ":LOCAL case")
+ (/show0 ":LOCAL case")
(let ((var (gensym))
(initval (if initial-value (gensym)))
(info (make-local-alien-info :type alien-type)))
(dispose-local-alien ',info ,var))))))))))))
(/show "revised" body)
(verify-local-auxiliaries-okay)
- (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
+ (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
`(symbol-macrolet ((&auxiliary-type-definitions&
,(append *new-auxiliary-types*
(auxiliary-type-definitions env))))
(parms (make-gensym-list (length args))))
(compile nil
`(lambda (,fun ,@parms)
+ (declare (optimize (sb!c::insert-step-conditions 0)))
(declare (type (alien ,type) ,fun))
(alien-funcall ,fun ,@parms)))))
(setf (alien-fun-type-stub type) stub))
way that the argument is passed.
:IN
- An :IN argument is simply passed by value. The value to be passed is
- obtained from argument(s) to the interface function. No values are
- returned for :In arguments. This is the default mode.
+ An :IN argument is simply passed by value. The value to be passed is
+ obtained from argument(s) to the interface function. No values are
+ returned for :In arguments. This is the default mode.
:OUT
- The specified argument type must be a pointer to a fixed sized object.
- A pointer to a preallocated object is passed to the routine, and the
- the object is accessed on return, with the value being returned from
- the interface function. :OUT and :IN-OUT cannot be used with pointers
- to arrays, records or functions.
+ The specified argument type must be a pointer to a fixed sized object.
+ A pointer to a preallocated object is passed to the routine, and the
+ the object is accessed on return, with the value being returned from
+ the interface function. :OUT and :IN-OUT cannot be used with pointers
+ to arrays, records or functions.
:COPY
- This is similar to :IN, except that the argument values are stored
+ This is similar to :IN, except that the argument values are stored
on the stack, and a pointer to the object is passed instead of
- the value itself.
+ the value itself.
:IN-OUT
- This is a combination of :OUT and :COPY. A pointer to the argument is
- passed, with the object being initialized from the supplied argument
+ This is a combination of :OUT and :COPY. A pointer to the argument is
+ passed, with the object being initialized from the supplied argument
and the return value being determined by accessing the object on
return."
(multiple-value-bind (lisp-name alien-name)
(typep object lisp-rep-type)
(and (alien-value-p object)
(alien-subtype-p (alien-value-type object) type)))))
+
+;;;; ALIEN CALLBACKS
+;;;;
+;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual.
+
+(defvar *alien-callback-info* nil
+ "Maps SAPs to corresponding CALLBACK-INFO structures: contains all the
+information we need to manipulate callbacks after their creation. Used for
+changing the lisp-side function they point to, invalidation, etc.")
+
+(defstruct callback-info
+ specifier
+ function ; NULL if invalid
+ wrapper
+ index)
+
+(defun callback-info-key (info)
+ (cons (callback-info-specifier info) (callback-info-function info)))
+
+(defun alien-callback-info (alien)
+ (cdr (assoc (alien-sap alien) *alien-callback-info* :test #'sap=)))
+
+(defvar *alien-callbacks* (make-hash-table :test #'equal)
+ "Cache of existing callback SAPs, indexed with (SPECIFER . FUNCTION). Used for
+memoization: we don't create new callbacks if one pointing to the correct
+function with the same specifier already exists.")
+
+(defvar *alien-callback-wrappers* (make-hash-table :test #'equal)
+ "Cache of existing lisp weappers, indexed with SPECIFER. Used for memoization:
+we don't create new wrappers if one for the same specifier already exists.")
+
+(defvar *alien-callback-trampolines* (make-array 32 :fill-pointer 0 :adjustable t)
+ "Lisp trampoline store: assembler wrappers contain indexes to this, and
+ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
+
+(defun %alien-callback-sap (specifier result-type argument-types function wrapper)
+ (let ((key (cons specifier function)))
+ (or (gethash key *alien-callbacks*)
+ (setf (gethash key *alien-callbacks*)
+ (let* ((index (fill-pointer *alien-callback-trampolines*))
+ ;; Aside from the INDEX this is known at
+ ;; compile-time, which could be utilized by
+ ;; having the two-stage assembler tramp &
+ ;; wrapper mentioned in [1] above: only the
+ ;; per-function tramp would need assembler at
+ ;; runtime. Possibly we could even pregenerate
+ ;; the code and just patch the index in later.
+ (assembler-wrapper (alien-callback-assembler-wrapper
+ index result-type argument-types)))
+ (vector-push-extend
+ (alien-callback-lisp-trampoline wrapper function)
+ *alien-callback-trampolines*)
+ (let ((sap (vector-sap assembler-wrapper)))
+ (push (cons sap (make-callback-info :specifier specifier
+ :function function
+ :wrapper wrapper
+ :index index))
+ *alien-callback-info*)
+ sap))))))
+
+(defun alien-callback-lisp-trampoline (wrapper function)
+ (declare (function wrapper) (optimize speed))
+ (lambda (args-pointer result-pointer)
+ (funcall wrapper args-pointer result-pointer function)))
+
+(defun alien-callback-lisp-wrapper-lambda (specifier result-type argument-types env)
+ (let* ((arguments (make-gensym-list (length argument-types)))
+ (argument-names arguments)
+ (argument-specs (cddr specifier)))
+ `(lambda (args-pointer result-pointer function)
+ (let ((args-sap (int-sap
+ (sb!kernel:get-lisp-obj-address args-pointer)))
+ (res-sap (int-sap
+ (sb!kernel:get-lisp-obj-address result-pointer))))
+ (with-alien
+ ,(loop
+ for spec in argument-specs
+ for offset = 0 ; FIXME: Should this not be AND OFFSET ...?
+ then (+ offset (alien-callback-argument-bytes spec env))
+ collect `(,(pop argument-names) ,spec
+ :local ,(alien-callback-accessor-form
+ spec 'args-sap offset)))
+ ,(flet ((store (spec)
+ (if spec
+ `(setf (deref (sap-alien res-sap (* ,spec)))
+ (funcall function ,@arguments))
+ `(funcall function ,@arguments))))
+ (cond ((alien-void-type-p result-type)
+ (store nil))
+ ((alien-integer-type-p result-type)
+ (if (alien-integer-type-signed result-type)
+ (store `(signed
+ ,(alien-type-word-aligned-bits result-type)))
+ (store
+ `(unsigned
+ ,(alien-type-word-aligned-bits result-type)))))
+ (t
+ (store (unparse-alien-type result-type)))))))
+ (values))))
+
+(defun invalid-alien-callback (&rest arguments)
+ (declare (ignore arguments))
+ (error "Invalid alien callback called."))
+
+
+(defun parse-callback-specification (result-type lambda-list)
+ (values
+ `(function ,result-type ,@(mapcar #'second lambda-list))
+ (mapcar #'first lambda-list)))
+
+
+(defun parse-alien-ftype (specifier env)
+ (destructuring-bind (function result-type &rest argument-types)
+ specifier
+ (aver (eq 'function function))
+ (values (parse-alien-type result-type env)
+ (mapcar (lambda (spec)
+ (parse-alien-type spec env))
+ argument-types))))
+
+(defun alien-void-type-p (type)
+ (and (alien-values-type-p type) (not (alien-values-type-values type))))
+
+(defun alien-type-word-aligned-bits (type)
+ (align-offset (alien-type-bits type) sb!vm:n-word-bits))
+
+(defun alien-callback-argument-bytes (spec env)
+ (let ((type (parse-alien-type spec env)))
+ (if (or (alien-integer-type-p type)
+ (alien-float-type-p type)
+ (alien-pointer-type-p type))
+ (ceiling (alien-type-word-aligned-bits type) sb!vm:n-byte-bits)
+ (error "Unsupported callback argument type: ~A" type))))
+
+(defun enter-alien-callback (index return arguments)
+ (funcall (aref *alien-callback-trampolines* index)
+ return
+ arguments))
+
+;;;; interface (not public, yet) for alien callbacks
+
+(defmacro alien-callback (specifier function &environment env)
+ "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to
+an alien function as a pointer to the FUNCTION. If a callback for the given
+SPECIFIER and FUNCTION already exists, it is returned instead of consing a new
+one."
+ ;; Pull out as much work as is convenient to macro-expansion time, specifically
+ ;; everything that can be done given just the SPECIFIER and ENV.
+ (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env)
+ `(%sap-alien
+ (%alien-callback-sap ',specifier ',result-type ',argument-types
+ ,function
+ (or (gethash ',specifier *alien-callback-wrappers*)
+ (setf (gethash ',specifier *alien-callback-wrappers*)
+ ,(alien-callback-lisp-wrapper-lambda
+ specifier result-type argument-types env))))
+ ',(parse-alien-type specifier env))))
+
+(defun alien-callback-p (alien)
+ "Returns true if the alien is associated with a lisp-side callback,
+and a secondary return value of true if the callback is still valid."
+ (let ((info (alien-callback-info alien)))
+ (when info
+ (values t (and (callback-info-function info) t)))))
+
+(defun alien-callback-function (alien)
+ "Returns the lisp function designator associated with the callback."
+ (let ((info (alien-callback-info alien)))
+ (when info
+ (callback-info-function info))))
+
+(defun (setf alien-callback-function) (function alien)
+ "Changes the lisp function designated by the callback."
+ (let ((info (alien-callback-info alien)))
+ (unless info
+ (error "Not an alien callback: ~S" alien))
+ ;; sap cache
+ (let ((key (callback-info-key info)))
+ (remhash key *alien-callbacks*)
+ (setf (gethash key *alien-callbacks*) (alien-sap alien)))
+ ;; trampoline
+ (setf (aref *alien-callback-trampolines* (callback-info-index info))
+ (alien-callback-lisp-trampoline (callback-info-wrapper info) function))
+ ;; metadata
+ (setf (callback-info-function info) function)
+ function))
+
+(defun invalidate-alien-callback (alien)
+ "Invalidates the callback designated by the alien, if any, allowing the
+associated lisp function to be GC'd, and causing further calls to the same
+callback signal an error."
+ (let ((info (alien-callback-info alien)))
+ (when (and info (callback-info-function info))
+ ;; sap cache
+ (remhash (callback-info-key info) *alien-callbacks*)
+ ;; trampoline
+ (setf (aref *alien-callback-trampolines* (callback-info-index info))
+ #'invalid-alien-callback)
+ ;; metadata
+ (setf (callback-info-function info) nil)
+ t)))
+
+;;; FIXME: This calls assembles a new callback for every closure,
+;;; which suck hugely. ...not that I can think of an obvious
+;;; solution. Possibly maybe we could write a generalized closure
+;;; callback analogous to closure_tramp, and share the actual wrapper?
+;;;
+;;; For lambdas that result in simple-funs we get the callback from
+;;; the cache on subsequent calls.
+(defmacro alien-lambda (result-type typed-lambda-list &body forms)
+ (multiple-value-bind (specifier lambda-list)
+ (parse-callback-specification result-type typed-lambda-list)
+ `(alien-callback ,specifier (lambda ,lambda-list ,@forms))))
+
+;;; FIXME: Should subsequent (SETF FDEFINITION) affect the callback or not?
+;;; What about subsequent DEFINE-ALIEN-CALLBACKs? My guess is that changing
+;;; the FDEFINITION should invalidate the callback, and redefining the
+;;; callback should change existing callbacks to point to the new defintion.
+(defmacro define-alien-callback (name result-type typed-lambda-list &body forms)
+ "Defines #'NAME as a function with the given body and lambda-list, and NAME as
+the alien callback for that function with the given alien type."
+ (declare (symbol name))
+ (multiple-value-bind (specifier lambda-list)
+ (parse-callback-specification result-type typed-lambda-list)
+ `(progn
+ (defun ,name ,lambda-list ,@forms)
+ (defparameter ,name (alien-callback ,specifier #',name)))))
projects / sbcl.git / blobdiff