Changed to use of settable FOREIGN-LOCATION

[clg] / glib / proxy.lisp

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index 5f0e5cfb24308aa22c31484d01cf50ce02c7fbe4..53d35babc44990d2602cf78a30d56f81eee5d0ea 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.25 2006-02-05 15:38:57 espen Exp $
+;; $Id: proxy.lisp,v 1.31 2006-02-08 22:10:47 espen Exp $

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


@@ -183,7 +183,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def
                     (slot-definition-type slotd))))
                 (funcall writer (foreign-location object) value)))))))))
 
                     (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
 
 
 ;;;; 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,17 +265,49 @@ (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 ()
 (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))
   (:metaclass virtual-slots-class))
 
 (defgeneric instance-finalizer (object))
 (defgeneric reference-foreign (class location))
 (defgeneric unreference-foreign (class location))

+(defgeneric invalidate-instance (object))
+
+(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))
 
 (defmethod reference-foreign ((name symbol) location)
   (reference-foreign (find-class name) location))


@@ -310,12 +341,19 @@ (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
 
 (defgeneric most-specific-proxy-superclass (class))
 (defgeneric direct-proxy-superclass (class))
 
 ;;;; 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)
   
 
 (eval-when (:compile-toplevel :load-toplevel :execute)


@@ -388,9 +426,6 @@   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-def
 
     (call-next-method))
   
 
     (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)
 
   ;; TODO: call some C code to detect this a compile time
   (defconstant +struct-alignmen+ 4)
 


@@ -418,12 +453,6 @@   (defmethod compute-slots ((class proxy-class))
        do (setf (slot-value slotd 'offset) offset))))
     (call-next-method))
 
        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))
   
   (defmethod validate-superclass ((class proxy-class) (super standard-class))
     (subtypep (class-name super) 'proxy))
   


@@ -489,7 +518,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))))))


@@ -509,7 +539,12 @@ (defun ensure-proxy-instance (class location &rest initargs)
 MAKE-PROXY-INSTANCE is called to create one."
   (unless (null-pointer-p location)
     (or 
 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))))
      (let ((instance (apply #'make-proxy-instance class location initargs)))
        (cache-instance instance)
        instance))))


@@ -519,13 +554,15 @@ (defgeneric make-proxy-instance (class location &key weak)
 object at the give location. If WEAK is non NIL the foreign memory
 will not be released when the proxy is garbage collected."))
 
 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)
 
 (defmethod make-proxy-instance ((class proxy-class) location &key weak)

-  (declare (ignore weak-p))
-  (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))
     (unless weak
       (finalize instance (instance-finalizer instance)))
     instance))


@@ -564,14 +601,28 @@ (defmethod reference-foreign ((class struct-class) location)
 (defmethod unreference-foreign ((class struct-class) location)
   (deallocate-memory 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 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) 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)


@@ -585,6 +636,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
 


@@ -595,10 +654,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))