X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/253c13397ee32afd6dcda1ddb9b5e601b7c27d06..4b8ed5d8fa92b43a08b774abd5b75e3819e0e95d:/glib/proxy.lisp diff --git a/glib/proxy.lisp b/glib/proxy.lisp index 844886a..4dcc407 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.32 2006/02/09 22:26:38 espen Exp $ (in-package "GLIB") @@ -84,7 +84,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (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)) @@ -163,9 +163,9 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (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 +183,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (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))) @@ -234,7 +234,6 @@ (defmethod validate-superclass ;;;; Proxy cache -(internal *instance-cache*) (defvar *instance-cache* (make-hash-table :test #'eql)) (defun cache-instance (instance &optional (weak-ref t)) @@ -266,19 +265,50 @@ (defun list-cached-instances () *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 :allocation :special :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)) @@ -296,8 +326,10 @@ (defmethod print-object ((instance proxy) stream) (format stream "at 0x~X" (sap-int (foreign-location instance))) (write-string "at \"unbound\"" 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 +344,19 @@ (defmethod instance-finalizer ((instance proxy)) (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) @@ -394,9 +429,6 @@ (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-def (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) @@ -424,12 +456,6 @@ (defmethod compute-slots ((class proxy-class)) 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)) @@ -495,7 +521,8 @@ (defmethod writer-function ((class proxy-class) &rest args) (defmethod reader-function ((class proxy-class) &rest args) (declare (ignore args)) - #'(lambda (location &optional (offset 0)) + #'(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)))))) @@ -515,6 +542,8 @@ (defun ensure-proxy-instance (class location &rest initargs) 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 +561,11 @@ (defmethod make-proxy-instance ((class symbol) location &rest initargs) (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,14 +578,12 @@ (defclass struct (proxy) (: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 @@ -572,21 +602,28 @@ (defmethod reference-foreign ((class struct-class) location) (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 weak-reader-function ((class struct-class) &rest args) +(defmethod compute-slots :around ((class struct-class)) + (let ((slots (call-next-method))) + (when (and + #-sbcl>=0.9.8(class-finalized-p class) #+sbc098 t + (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)) + +(defmethod reader-function ((class struct-class) &rest args) (declare (ignore args)) - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) (let ((instance (sap-ref-sap location offset))) (unless (null-pointer-p instance) - (ensure-proxy-instance class instance :weak t))))) + (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,6 +637,14 @@ (defmethod unreference-foreign ((class static-struct-class) location) (declare (ignore class location)) nil) +(defmethod reader-function ((class struct-class) &rest args) + (declare (ignore args)) + #'(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 instance :weak t))))) + ;;; Pseudo type for structs which are inlined in other objects @@ -610,7 +655,8 @@ (defmethod size-of ((type (eql 'inlined)) &rest args) (defmethod reader-function ((type (eql 'inlined)) &rest args) (declare (ignore type)) (destructuring-bind (class) args - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (ensure-proxy-instance class (reference-foreign class (sap+ location offset))))))