Added caching of invalidated proxy instances

[clg] / glib / proxy.lisp

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index 994e880df7a2ff7728a5bb0274532a3a9179db51..aad291858a80361be4cacf00ba610b5106cb2bf8 100644 (file)
--- 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.
 
 ;; 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.24 2006-02-04 12:15:32 espen Exp $
+;; $Id: proxy.lisp,v 1.29 2006-02-07 13:20:39 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -234,7 +234,6 @@ (defmethod validate-superclass
 
 ;;;; Proxy cache
 
 
 ;;;; Proxy cache
 

-(internal *instance-cache*)

 (defvar *instance-cache* (make-hash-table :test #'eql))
 
 (defun cache-instance (instance &optional (weak-ref t))
 (defvar *instance-cache* (make-hash-table :test #'eql))
 
 (defun cache-instance (instance &optional (weak-ref t))


@@ -266,10 +265,32 @@ (defun list-cached-instances ()
             *instance-cache*)
     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
 
 
 
 ;;;; 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))
 (defclass proxy ()
   ((location :allocation :special :reader foreign-location :type pointer))
   (:metaclass virtual-slots-class))


@@ -277,6 +298,7 @@ (defclass proxy ()
 (defgeneric instance-finalizer (object))
 (defgeneric reference-foreign (class location))
 (defgeneric unreference-foreign (class location))
 (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))
 
 (defmethod reference-foreign ((name symbol) location)
   (reference-foreign (find-class name) location))


@@ -294,13 +316,12 @@ (defmethod print-object ((instance proxy) stream)
        (format stream "at 0x~X" (sap-int (foreign-location instance)))
       (write-string "at \"unbound\"" stream))))
 
        (format stream "at 0x~X" (sap-int (foreign-location instance)))
       (write-string "at \"unbound\"" stream))))
 

-(defmethod initialize-instance :around ((instance proxy) &key location)
-  (if location
-      (setf (slot-value instance 'location) location)      
-    (call-next-method))
-  (cache-instance instance)
-  (finalize instance (instance-finalizer instance))
-  instance)
+(defmethod initialize-instance :around ((instance proxy) &rest initargs)
+  (declare (ignore initargs))
+  (prog1
+      (call-next-method)
+    (cache-instance instance)
+    (finalize instance (instance-finalizer instance))))

 
 (defmethod instance-finalizer ((instance proxy))
   (let ((location (foreign-location instance))
 
 (defmethod instance-finalizer ((instance proxy))
   (let ((location (foreign-location instance))


@@ -311,6 +332,14 @@ (defmethod instance-finalizer ((instance proxy))
        (remove-cached-instance location)
        (unreference-foreign class location))))
 
        (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
 
 
 ;;;; Metaclass used for subclasses of proxy
 


@@ -490,7 +519,8 @@ (defmethod writer-function ((class proxy-class) &rest args)
 
 (defmethod reader-function ((class proxy-class) &rest args)
   (declare (ignore 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))))))
       (let ((instance (sap-ref-sap location offset)))
        (unless (null-pointer-p instance)
          (ensure-proxy-instance class (reference-foreign class instance))))))


@@ -504,20 +534,39 @@ (defmethod unbound-value ((class proxy-class) &rest args)
   (declare (ignore args))
   (values t nil))
 
   (declare (ignore args))
   (values t nil))
 

-(defgeneric ensure-proxy-instance (class location)
-  (:documentation "Returns a proxy object representing the foreign object at the give location."))
-
-(defmethod ensure-proxy-instance :around (class location)
+(defun ensure-proxy-instance (class location &rest initargs)
+  "Returns a proxy object representing the foreign object at the give
+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 
   (unless (null-pointer-p location)
     (or 

-     (find-cached-instance location)
-     (call-next-method))))
-  
-(defmethod ensure-proxy-instance ((class symbol) location)
-  (ensure-proxy-instance (find-class class) location))
-
-(defmethod ensure-proxy-instance ((class proxy-class) location)
-  (make-instance class :location 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))))
+
+(defgeneric make-proxy-instance (class location &key weak)
+  (:documentation "Creates a new proxy object representing the foreign
+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 &rest initargs)
+  (apply #'make-proxy-instance (find-class class) location initargs))
+
+(defmethod make-proxy-instance ((class proxy-class) location &key weak)
+  (let ((instance
+        (or
+         (find-invalidated-instance class)
+         (allocate-instance class))))
+    (setf (slot-value instance 'location) location)
+    (unless weak
+      (finalize instance (instance-finalizer instance)))
+    instance))

 
 
 ;;;; Superclasses for wrapping of C structures
 
 
 ;;;; Superclasses for wrapping of C structures


@@ -562,6 +611,15 @@ (defmethod compute-foreign-size ((class struct-class))
                         (size-of (slot-definition-type slotd))))))
     (+ size (mod size +struct-alignmen+))))
 
                         (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)
   ())
 
 (defclass static-struct-class (struct-class)
   ())


@@ -574,6 +632,14 @@ (defmethod unreference-foreign ((class static-struct-class) location)
   (declare (ignore class location))
   nil)
 
   (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
 
 
 ;;; Pseudo type for structs which are inlined in other objects
 


@@ -584,10 +650,17 @@ (defmethod size-of ((type (eql 'inlined)) &rest args)
 (defmethod reader-function ((type (eql 'inlined)) &rest args)
   (declare (ignore type))
   (destructuring-bind (class) 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))))))
 
        (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))
 (defmethod destroy-function ((type (eql 'inlined)) &rest args)
   (declare (ignore args))
   #'(lambda (location &optional (offset 0))