X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=019991d6e1cf5e79537b880986d5f8fb203f472f;hb=568214ddf4c8ecc881caec98e20848d017974ec0;hp=2f62bfc54c128c30760c662107b576c4c701dd97;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 2f62bfc..019991d 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -580,6 +580,7 @@ (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)) @@ -722,3 +723,230 @@ (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)))))