From 6cb01770be85e0164c2cdf89e7d6a626dcaf702d Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 16 Jun 2005 12:43:51 +0000 Subject: [PATCH] 0.9.1.46: refactoring callbacks * turn ALIEN-CALLBACK into a macro so we avoid a runtime call to the compiler. * additional bits of interface: ALIEN-CALLBACK-P, ALIEN-CALLBACK-FUNCTION, (SETF ALIEN-CALLBACK-FUNCTION), and INVALIDATE-ALIEN-CALLBACK. * more tests. --- src/code/target-alieneval.lisp | 284 ++++++++++++++++++++++++++-------------- tests/callback.impure.lisp | 56 +++++++- version.lisp-expr | 2 +- 3 files changed, 239 insertions(+), 103 deletions(-) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index a6c5afe..4ae19e5 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -724,9 +724,9 @@ (and (alien-value-p object) (alien-subtype-p (alien-value-type object) type))))) -;;;; ALIEN-CALLBACKS +;;;; ALIEN CALLBACKS ;;;; -;;;; An alien callback has 4 parts / stages: +;;;; An alien callback sequence has 4 parts / stages / bounces: ;;;; ;;;; * ASSEMBLER WRAPPER that saves the arguments from the C-call ;;;; according to the alien-fun-type of the callback, and calls @@ -758,112 +758,111 @@ ;;;; the callbacks with the same alien-fun-type. This would amortize ;;;; most of the static allocation costs between multiple callbacks. +(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) - "Maps (SPECIFIER . FUNCTION) to callbacks.") + "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-trampolines* (make-array 32 :fill-pointer 0 :adjustable t) - "Maps alien callback indexes to lisp trampolines.") +(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.") -(defparameter *alien-callback-wrappers* (make-hash-table :test #'equal) - "Maps SPECIFIER to lisp wrappers.") +(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.")) -;;; FIXME: This involves a call to both the compiler and assembler, so -;;; should either be macroized to do more of the work at compile-time, -;;; or perhaps named COMPILE-ALIEN, or somesuch. -;;; -;;; FIXME: It is also probably worth our while to optimize cases like -;;; (alien-funcall spec 'symbol). -(defun alien-callback (specifier function &optional env) - "Returns an alien-value with of alien type SPECIFIER, that can be passed to an -alien function as a pointer to the FUNCTION." - (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) - (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)) - ;;; For normal use-cases this at least could be - ;;; done at compile-time. - (lisp-wrapper (alien-callback-lisp-wrapper - specifier result-type argument-types env))) - (vector-push-extend - (lambda (args-pointer result-pointer) - (funcall lisp-wrapper args-pointer result-pointer function)) - *alien-callback-trampolines*) - (%sap-alien (vector-sap assembler-wrapper) - (parse-alien-type specifier env)))))))) (defun parse-callback-specification (result-type lambda-list) (values `(function ,result-type ,@(mapcar #'second lambda-list)) (mapcar #'first lambda-list))) -;;; FIXME: This calls compiler every single time, which really sucks. -;;; -;;; The problem is that we need to return a pointer to the right closure, -;;; even though the underlying function gets shared. What to do? -;;; -;;; -(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)))) - -(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." - (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))))) - -(defun alien-callback-lisp-wrapper (specifier result-type argument-types env) - (or (gethash specifier *alien-callback-wrappers*) - (setf (gethash specifier *alien-callback-wrappers*) - (compile - nil - (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 parse-alien-ftype (specifier env) (destructuring-bind (function result-type &rest argument-types) @@ -892,3 +891,92 @@ the alien callback for that function with the given alien type." (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))))) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 360224b..f1b1783 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -13,25 +13,33 @@ (in-package :cl-user) -(defun alien-callback (type fun) - (sb-alien-internals:alien-callback type fun)) +;;; callbacks only on ppc/darwin currently +#-darwin (quit :unix-status 104) + +;;; simple callback for a function (defun thunk () (write-string "hi")) -(defvar *thunk* (alien-callback '(function c-string) #'thunk)) +(defvar *thunk* + (sb-alien::alien-callback (function c-string) #'thunk)) (assert (equal (with-output-to-string (*standard-output*) (alien-funcall *thunk*)) "hi")) +;;; simple callback for a symbol + (defun add-two-ints (arg1 arg2) (+ arg1 arg2)) -(defvar *add-two-ints* (alien-callback '(function int int int) 'add-two-ints)) +(defvar *add-two-ints* + (sb-alien::alien-callback (function int int int) 'add-two-ints)) (assert (= (alien-funcall *add-two-ints* 555 444444) 444999)) +;;; actually using a callback with foreign code + (define-alien-routine qsort void (base (* t)) (nmemb int) @@ -56,6 +64,7 @@ double*-cmp)) (assert (equalp vector sorted))) +;;; returning floats (sb-alien::define-alien-callback redefined-fun int () 0) @@ -77,4 +86,43 @@ (assert (= spi (alien-funcall return-single spi))) (assert (= pi (alien-funcall return-double pi))) +;;; invalidation + +(sb-alien::define-alien-callback to-be-invalidated int () + 5) + +(assert (= 5 (alien-funcall to-be-invalidated))) + +(multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated) + (assert p) + (assert valid)) + +(sb-alien::invalidate-alien-callback to-be-invalidated) + +(multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated) + (assert p) + (assert (not valid))) + +(multiple-value-bind (res err) + (ignore-errors (alien-funcall to-be-invalidated)) + (assert (and (not res) (typep err 'error)))) + +;;; getting and setting the underlying function + +(sb-alien::define-alien-callback foo int () + 13) + +(defvar *foo* #'foo) + +(assert (eq #'foo (sb-alien::alien-callback-function foo))) + +(defun bar () + 26) + +(setf (sb-alien::alien-callback-function foo) #'bar) + +(assert (eq #'bar (sb-alien::alien-callback-function foo))) + +(assert (= 26 (alien-funcall foo))) + (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 2a7150c..034fd12 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.45" +"0.9.1.46" -- 1.7.10.4