X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/8958fa4a2ce3f4163fe4798e6d29da534f96075a..ca01de1b4128e7b32b56e14b091762f2bce0d33d:/glib/proxy.lisp diff --git a/glib/proxy.lisp b/glib/proxy.lisp index 5f0e5cf..aad2918 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.25 2006-02-05 15:38:57 espen Exp $ +;; $Id: proxy.lisp,v 1.29 2006-02-07 13:20:39 espen Exp $ (in-package "GLIB") @@ -234,7 +234,6 @@ ;;;; Proxy cache -(internal *instance-cache*) (defvar *instance-cache* (make-hash-table :test #'eql)) (defun cache-instance (instance &optional (weak-ref t)) @@ -266,10 +265,32 @@ *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)) (:metaclass virtual-slots-class)) @@ -277,6 +298,7 @@ (defgeneric instance-finalizer (object)) (defgeneric reference-foreign (class location)) (defgeneric unreference-foreign (class location)) +(defgeneric invalidate-instance (object)) (defmethod reference-foreign ((name symbol) location) (reference-foreign (find-class name) location)) @@ -310,6 +332,14 @@ (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) + (cancel-finalization instance) + (cache-invalidated-instance instance)) + ;;;; Metaclass used for subclasses of proxy @@ -489,7 +519,8 @@ (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)))))) @@ -509,7 +540,12 @@ 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 - (find-cached-instance location) + #-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) + instance)) (let ((instance (apply #'make-proxy-instance class location initargs))) (cache-instance instance) instance)))) @@ -519,12 +555,14 @@ MAKE-PROXY-INSTANCE is called to create one." object at the give location. If WEAK is non NIL the foreign memory will not be released when the proxy is garbage collected.")) -(defmethod make-proxy-instance ((class symbol) location &key weak) - (ensure-proxy-instance (find-class class) location :weak weak)) +(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) - (declare (ignore weak-p)) - (let ((instance (allocate-instance class))) + (let ((instance + (or + (find-invalidated-instance class) + (allocate-instance class)))) (setf (slot-value instance 'location) location) (unless weak (finalize instance (instance-finalizer instance))) @@ -573,6 +611,15 @@ will not be released when the proxy is garbage collected.")) (size-of (slot-definition-type slotd)))))) (+ size (mod size +struct-alignmen+)))) +(defmethod reader-function ((class struct-class) &rest args) + (declare (ignore args)) + #'(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) ()) @@ -585,6 +632,14 @@ will not be released when the proxy is garbage collected.")) (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 @@ -595,10 +650,17 @@ will not be released when the proxy is garbage collected.")) (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)))))) +(defmethod writer-function ((type (eql 'inlined)) &rest args) + (declare (ignore type)) + (destructuring-bind (class) args + #'(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))