X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/4a64c16d900f59a4e6b1ac57fc8658f6faabbcfc..1dc849d71672aa3b250e852965d3b13b65f4e0f4:/glib/proxy.lisp diff --git a/glib/proxy.lisp b/glib/proxy.lisp index ff08b84..bd74e77 100644 --- a/glib/proxy.lisp +++ b/glib/proxy.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: proxy.lisp,v 1.26 2006-02-06 11:52:24 espen Exp $ +;; $Id: proxy.lisp,v 1.38 2006-03-03 10:01:47 espen Exp $ (in-package "GLIB") @@ -43,10 +43,10 @@ (boundp :reader slot-definition-boundp :initarg :boundp))) (defclass direct-special-slot-definition (standard-direct-slot-definition) - ()) + ((special :initarg :special :accessor slot-definition-special))) (defclass effective-special-slot-definition (standard-effective-slot-definition) - ())) + ((special :initarg :special :accessor slot-definition-special)))) (defvar *unbound-marker* (gensym "UNBOUND-MARKER-")) @@ -59,23 +59,22 @@ (slot-value object slot) default))) -(defmethod initialize-instance ((slotd effective-special-slot-definition) &rest initargs) - (declare (ignore initargs)) - (call-next-method) - (setf (slot-value slotd 'allocation) :instance)) - (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs) - (case (getf initargs :allocation) - (:virtual (find-class 'direct-virtual-slot-definition)) - (:special (find-class 'direct-special-slot-definition)) - (t (call-next-method)))) + (cond + ((eq (getf initargs :allocation) :virtual) + (find-class 'direct-virtual-slot-definition)) + ((getf initargs :special) + (find-class 'direct-special-slot-definition)) + (t (call-next-method)))) (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs) - (case (getf initargs :allocation) - (:virtual (find-class 'effective-virtual-slot-definition)) - (:special (find-class 'effective-special-slot-definition)) - (t (call-next-method)))) + (cond + ((eq (getf initargs :allocation) :virtual) + (find-class 'effective-virtual-slot-definition)) + ((getf initargs :special) + (find-class 'effective-special-slot-definition)) + (t (call-next-method)))) (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition)) @@ -84,7 +83,7 @@ (slot-value slotd 'reader-function) #'(lambda (object) (declare (ignore object)) - (error "Can't read slot: ~A" (slot-definition-name slotd))) + (error "Slot is not readable: ~A" (slot-definition-name slotd))) (slot-value slotd 'boundp-function) #'(lambda (object) (declare (ignore object)) nil)) @@ -125,11 +124,14 @@ (mkbinding boundp (slot-definition-type slotd) 'pointer))) (funcall reader (foreign-location object)))))))) - ((multiple-value-bind (unbound-p unbound-value) - (unbound-value (slot-definition-type slotd)) - (when unbound-p - #'(lambda (object) - (not (eq (funcall getter-function object) unbound-value)))))) + ((let ((unbound-value-method + (find-applicable-type-method 'unbound-value + (slot-definition-type slotd) nil))) + (when unbound-value-method + (let ((unbound-value + (funcall unbound-value-method (slot-definition-type slotd)))) + #'(lambda (object) + (not (eq (funcall getter-function object) unbound-value))))))) (#'(lambda (object) (declare (ignore object)) t)))) (setf @@ -149,10 +151,13 @@ (and (funcall boundp-function object) (funcall getter-function object))))) - ((multiple-value-bind (unbound-p unbound-value) - (unbound-value (slot-definition-type slotd)) - (let ((slot-name (slot-definition-name slotd))) - (when unbound-p + ((let ((unbound-value-method + (find-applicable-type-method 'unbound-value + (slot-definition-type slotd) nil))) + (when unbound-value-method + (let ((unbound-value + (funcall unbound-value-method (slot-definition-type slotd))) + (slot-name (slot-definition-name slotd))) #'(lambda (object) (let ((value (funcall getter-function object))) (if (eq value unbound-value) @@ -163,9 +168,9 @@ (setf (slot-value slotd 'writer-function) (if (not (slot-boundp slotd 'setter)) - #'(lambda (object) - (declare (ignore object)) - (error "Can't set slot: ~A" (slot-definition-name slotd))) + #'(lambda (value object) + (declare (ignore value object)) + (error "Slot is not writable: ~A" (slot-definition-name slotd))) (with-slots (setter) slotd (etypecase setter (function setter) @@ -183,7 +188,7 @@ (slot-definition-type slotd)))) (funcall writer (foreign-location object) value))))))))) - (initialize-internal-slot-gfs (slot-definition-name slotd))) + #-sbcl>=0.9.8(initialize-internal-slot-gfs (slot-definition-name slotd))) @@ -191,22 +196,29 @@ nil) (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds) - (if (typep (first direct-slotds) 'direct-virtual-slot-definition) - (let ((initargs ())) - (let ((getter (most-specific-slot-value direct-slotds 'getter))) - (unless (eq getter *unbound-marker*) - (setf (getf initargs :getter) getter))) - (let ((setter (most-specific-slot-value direct-slotds 'setter))) - (unless (eq setter *unbound-marker*) - (setf (getf initargs :setter) setter))) - (let ((unbound (most-specific-slot-value direct-slotds 'unbound))) - (unless (eq unbound *unbound-marker*) - (setf (getf initargs :unbound) unbound))) - (let ((boundp (most-specific-slot-value direct-slotds 'boundp))) - (unless (eq boundp *unbound-marker*) - (setf (getf initargs :boundp) boundp))) - (nconc initargs (call-next-method))) - (call-next-method))) + (typecase (first direct-slotds) + (direct-virtual-slot-definition + (let ((initargs ())) + (let ((getter (most-specific-slot-value direct-slotds 'getter))) + (unless (eq getter *unbound-marker*) + (setf (getf initargs :getter) getter))) + (let ((setter (most-specific-slot-value direct-slotds 'setter))) + (unless (eq setter *unbound-marker*) + (setf (getf initargs :setter) setter))) + (let ((unbound (most-specific-slot-value direct-slotds 'unbound))) + (unless (eq unbound *unbound-marker*) + (setf (getf initargs :unbound) unbound))) + (let ((boundp (most-specific-slot-value direct-slotds 'boundp))) + (unless (eq boundp *unbound-marker*) + (setf (getf initargs :boundp) boundp))) + ;; Need this to prevent type expansion in SBCL >= 0.9.8 + (let ((type (most-specific-slot-value direct-slotds 'type))) + (unless (eq type *unbound-marker*) + (setf (getf initargs :type) type))) + (nconc initargs (call-next-method)))) + (direct-special-slot-definition + (append '(:special t) (call-next-method))) + (t (call-next-method)))) (defmethod slot-value-using-class @@ -232,9 +244,17 @@ t) +(defmethod slot-definition-special ((slotd standard-direct-slot-definition)) + (declare (ignore slotd)) + nil) + +(defmethod slot-definition-special ((slotd standard-effective-slot-definition)) + (declare (ignore slotd)) + nil) + + ;;;; Proxy cache -(internal *instance-cache*) (defvar *instance-cache* (make-hash-table :test #'eql)) (defun cache-instance (instance &optional (weak-ref t)) @@ -266,19 +286,50 @@ *instance-cache*) instances)) +;; Instances that gets invalidated tend to be short lived, but created +;; in large numbers. So we're keeping them in a hash table to be able +;; to reuse them (and thus reduce consing) +(defvar *invalidated-instance-cache* (make-hash-table :test #'eql)) + +(defun cache-invalidated-instance (instance) + (push instance + (gethash (class-of instance) *invalidated-instance-cache*))) + +(defun find-invalidated-instance (class) + (when (gethash class *invalidated-instance-cache*) + (pop (gethash class *invalidated-instance-cache*)))) + +(defun list-invalidated-instances () + (let ((instances ())) + (maphash #'(lambda (location ref) + (declare (ignore location)) + (push ref instances)) + *invalidated-instance-cache*) + instances)) + ;;;; Proxy for alien instances ;; TODO: add a ref-counted-proxy subclass (defclass proxy () - ((location :allocation :special :reader foreign-location :type pointer)) + ((location :special t :type pointer)) (:metaclass virtual-slots-class)) (defgeneric instance-finalizer (object)) (defgeneric reference-foreign (class location)) (defgeneric unreference-foreign (class location)) (defgeneric invalidate-instance (object)) +(defgeneric allocate-foreign (object &key &allow-other-keys)) + +(defun foreign-location (instance) + (slot-value instance 'location)) + +(defun (setf foreign-location) (location instance) + (setf (slot-value instance 'location) location)) + +(defun proxy-valid-p (instance) + (slot-boundp instance 'location)) (defmethod reference-foreign ((name symbol) location) (reference-foreign (find-class name) location)) @@ -294,10 +345,12 @@ (print-unreadable-object (instance stream :type t :identity nil) (if (slot-boundp instance 'location) (format stream "at 0x~X" (sap-int (foreign-location instance))) - (write-string "at \"unbound\"" stream)))) + (write-string "at " stream)))) -(defmethod initialize-instance :around ((instance proxy) &rest initargs) - (declare (ignore initargs)) +(defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys) + (setf + (foreign-location instance) + (apply #'allocate-foreign instance initargs)) (prog1 (call-next-method) (cache-instance instance) @@ -312,16 +365,19 @@ (remove-cached-instance location) (unreference-foreign class location)))) +;; Any reference to the foreign object the instance may have held +;; should be released before this method is invoked (defmethod invalidate-instance ((instance proxy)) (remove-cached-instance (foreign-location instance)) - (slot-makunbound instance 'location)) + (slot-makunbound instance 'location) + (cancel-finalization instance) + (cache-invalidated-instance instance)) ;;;; Metaclass used for subclasses of proxy (defgeneric most-specific-proxy-superclass (class)) (defgeneric direct-proxy-superclass (class)) -(defgeneric compute-foreign-size (class)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -329,8 +385,8 @@ ((size :reader foreign-size))) (defclass direct-alien-slot-definition (direct-virtual-slot-definition) - ((allocation :initform :alien) - (offset :reader slot-definition-offset :initarg :offset))) + ((offset :reader slot-definition-offset :initarg :offset)) + (:default-initargs :allocation :alien)) (defclass effective-alien-slot-definition (effective-virtual-slot-definition) ((offset :reader slot-definition-offset :initarg :offset))) @@ -365,7 +421,7 @@ (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds) - (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien) + (if (eq (slot-definition-allocation (first direct-slotds)) :alien) (nconc (list :offset (most-specific-slot-value direct-slotds 'offset)) (call-next-method)) @@ -394,11 +450,12 @@ (call-next-method)) - (defmethod compute-foreign-size ((class proxy-class)) - nil) - - ;; TODO: call some C code to detect this a compile time - (defconstant +struct-alignmen+ 4) + (defconstant +struct-alignmen+ + #+sbcl (/ (sb-alien-internals:alien-type-alignment + (sb-alien-internals:parse-alien-type + 'system-area-pointer nil)) + 8) + #-sbcl 4) (defun align-offset (size) (if (zerop (mod size +struct-alignmen+)) @@ -424,12 +481,6 @@ do (setf (slot-value slotd 'offset) offset)))) (call-next-method)) - (defmethod compute-slots :after ((class proxy-class)) - (when (and (class-finalized-p class) (not (slot-boundp class 'size))) - (let ((size (compute-foreign-size class))) - (when size - (setf (slot-value class 'size) size))))) - (defmethod validate-superclass ((class proxy-class) (super standard-class)) (subtypep (class-name super) 'proxy)) @@ -440,74 +491,73 @@ (foreign-size (class-of object))) -(defmethod alien-type ((class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method alien-type ((class proxy)) + (declare (ignore class)) (alien-type 'pointer)) -(defmethod size-of ((class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method size-of ((class proxy)) + (declare (ignore class)) (size-of 'pointer)) -(defmethod from-alien-form (location (class proxy-class) &rest args) - (declare (ignore args)) - `(ensure-proxy-instance ',(class-name class) ,location)) +(define-type-method from-alien-form ((type proxy) location) + (let ((class (type-expand type))) + `(ensure-proxy-instance ',class ,location))) -(defmethod from-alien-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location) - (ensure-proxy-instance class location))) +(define-type-method from-alien-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location) + (ensure-proxy-instance class location)))) -(defmethod to-alien-form (instance (class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method to-alien-form ((type proxy) instance) + (declare (ignore type)) `(foreign-location ,instance)) -(defmethod to-alien-function ((class proxy-class) &rest args) - (declare (ignore class args)) +(define-type-method to-alien-function ((type proxy)) + (declare (ignore type)) #'foreign-location) -(defmethod copy-from-alien-form (location (class proxy-class) &rest args) - (declare (ignore args)) - (let ((class-name (class-name class))) - `(ensure-proxy-instance ',class-name - (reference-foreign ',class-name ,location)))) - -(defmethod copy-from-alien-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location) - (ensure-proxy-instance class (reference-foreign class location)))) - -(defmethod copy-to-alien-form (instance (class proxy-class) &rest args) - (declare (ignore args)) - `(reference-foreign ',(class-name class) (foreign-location ,instance))) - -(defmethod copy-to-alien-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (instance) - (reference-foreign class (foreign-location instance)))) - -(defmethod writer-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (instance location &optional (offset 0)) - (assert (null-pointer-p (sap-ref-sap location offset))) - (setf - (sap-ref-sap location offset) - (reference-foreign class (foreign-location instance))))) +(define-type-method copy-from-alien-form ((type proxy) location) + (let ((class (type-expand type))) + `(ensure-proxy-instance ',class (reference-foreign ',class ,location)))) -(defmethod reader-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0)) - (let ((instance (sap-ref-sap location offset))) - (unless (null-pointer-p instance) - (ensure-proxy-instance class (reference-foreign class instance)))))) +(define-type-method copy-from-alien-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location) + (ensure-proxy-instance class (reference-foreign class location))))) -(defmethod destroy-function ((class proxy-class) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0)) - (unreference-foreign class (sap-ref-sap location offset)))) +(define-type-method copy-to-alien-form ((type proxy) instance) + (let ((class (type-expand type))) + `(reference-foreign ',class (foreign-location ,instance)))) -(defmethod unbound-value ((class proxy-class) &rest args) - (declare (ignore args)) - (values t nil)) +(define-type-method copy-to-alien-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (instance) + (reference-foreign class (foreign-location instance))))) + +(define-type-method writer-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (instance location &optional (offset 0)) + (assert (null-pointer-p (sap-ref-sap location offset))) + (setf + (sap-ref-sap location offset) + (reference-foreign class (foreign-location instance)))))) + +(define-type-method reader-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) + (let ((instance (sap-ref-sap location offset))) + (unless (null-pointer-p instance) + (ensure-proxy-instance class (reference-foreign class instance))))))) + +(define-type-method destroy-function ((type proxy)) + (let ((class (type-expand type))) + #'(lambda (location &optional (offset 0)) + (unreference-foreign class (sap-ref-sap location offset))))) + +(define-type-method unbound-value ((type proxy)) + (declare (ignore type)) + nil) (defun ensure-proxy-instance (class location &rest initargs) "Returns a proxy object representing the foreign object at the give @@ -515,6 +565,8 @@ location. If an existing object is not found in the cache MAKE-PROXY-INSTANCE is called to create one." (unless (null-pointer-p location) (or + #-debug-ref-counting(find-cached-instance location) + #+debug-ref-counting (let ((instance (find-cached-instance location))) (when instance (format t "Object found in cache: ~A~%" instance) @@ -532,8 +584,11 @@ will not be released when the proxy is garbage collected.")) (apply #'make-proxy-instance (find-class class) location initargs)) (defmethod make-proxy-instance ((class proxy-class) location &key weak) - (let ((instance (allocate-instance class))) - (setf (slot-value instance 'location) location) + (let ((instance + (or + (find-invalidated-instance class) + (allocate-instance class)))) + (setf (foreign-location instance) location) (unless weak (finalize instance (instance-finalizer instance))) instance)) @@ -546,20 +601,19 @@ will not be released when the proxy is garbage collected.")) (:metaclass proxy-class) (:size 0)) -(defmethod initialize-instance ((struct struct) &rest initargs) +(defmethod allocate-foreign ((struct struct) &rest initargs) (declare (ignore initargs)) - (unless (slot-boundp struct 'location) - (let ((size (foreign-size (class-of struct)))) - (if (zerop size) - (error "~A has zero size" (class-of struct)) - (setf (slot-value struct 'location) (allocate-memory size))))) - (call-next-method)) + (let ((size (foreign-size (class-of struct)))) + (if (zerop size) + (error "~A has zero size" (class-of struct)) + (allocate-memory size)))) ;;;; Metaclasses used for subclasses of struct -(defclass struct-class (proxy-class) - ()) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass struct-class (proxy-class) + ())) (defmethod direct-slot-definition-class ((class struct-class) &rest initargs) (if (not (getf initargs :allocation)) @@ -572,21 +626,36 @@ will not be released when the proxy is garbage collected.")) (defmethod unreference-foreign ((class struct-class) location) (deallocate-memory location)) -(defmethod compute-foreign-size ((class struct-class)) - (let ((size (loop - for slotd in (class-slots class) - when (eq (slot-definition-allocation slotd) :alien) - maximize (+ - (slot-definition-offset slotd) - (size-of (slot-definition-type slotd)))))) - (+ size (mod size +struct-alignmen+)))) +(defmethod compute-slots :around ((class struct-class)) + (let ((slots (call-next-method))) + (when (and + #-sbcl>=0.9.8(class-finalized-p class) + (not (slot-boundp class 'size))) + (let ((size (loop + for slotd in slots + when (eq (slot-definition-allocation slotd) :alien) + maximize (+ + (slot-definition-offset slotd) + (size-of (slot-definition-type slotd)))))) + (setf (slot-value class 'size) (+ size (mod size +struct-alignmen+))))) + slots)) + +(define-type-method callback-from-alien-form ((type struct) form) + (let ((class (type-expand type))) + `(ensure-proxy-instance ',class ,form :weak t))) + +(define-type-method callback-cleanup-form ((type struct) form) + (declare (ignore type)) + `(invalidate-instance ,form)) -(defmethod weak-reader-function ((class struct-class) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0)) - (let ((instance (sap-ref-sap location offset))) - (unless (null-pointer-p instance) - (ensure-proxy-instance class instance :weak t))))) +(define-type-method reader-function ((type struct)) + (let ((class (type-expand type))) + #'(lambda (location &optional (offset 0) weak-p) + (let ((instance (sap-ref-sap location offset))) + (unless (null-pointer-p instance) + (if weak-p + (ensure-proxy-instance class instance :weak t) + (ensure-proxy-instance class (reference-foreign class instance)))))))) (defclass static-struct-class (struct-class) @@ -600,29 +669,30 @@ will not be released when the proxy is garbage collected.")) (declare (ignore class location)) nil) - ;;; Pseudo type for structs which are inlined in other objects -(defmethod size-of ((type (eql 'inlined)) &rest args) - (declare (ignore type)) - (foreign-size (first args))) +(deftype inlined (type) type) -(defmethod reader-function ((type (eql 'inlined)) &rest args) - (declare (ignore type)) - (destructuring-bind (class) args - #'(lambda (location &optional (offset 0)) +(define-type-method size-of ((type inlined)) + (let ((class (second (type-expand-to 'inlined type)))) + (foreign-size class))) + +(define-type-method reader-function ((type inlined)) + (let ((class (second (type-expand-to 'inlined type)))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (ensure-proxy-instance class (reference-foreign class (sap+ location offset)))))) -(defmethod writer-function ((type (eql 'inlined)) &rest args) - (declare (ignore type)) - (destructuring-bind (class) args +(define-type-method writer-function ((type inlined)) + (let ((class (second (type-expand-to 'inlined type)))) #'(lambda (instance location &optional (offset 0)) (copy-memory (foreign-location instance) (foreign-size class) (sap+ location offset))))) -(defmethod destroy-function ((type (eql 'inlined)) &rest args) - (declare (ignore args)) - #'(lambda (location &optional (offset 0)) +(define-type-method destroy-function ((type inlined)) + (declare (ignore type)) + #'(lambda (location &optional offset) (declare (ignore location offset)))) + (export 'inlined)