X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/09f6e23711ab7b3b8f713f0cabdaeffcc7c4ac20..ca01de1b4128e7b32b56e14b091762f2bce0d33d:/glib/proxy.lisp diff --git a/glib/proxy.lisp b/glib/proxy.lisp index 994e880..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.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") @@ -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,10 +265,32 @@ (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)) (: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 invalidate-instance (object)) (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)))) -(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)) @@ -311,6 +332,14 @@ (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) + (cancel-finalization instance) + (cache-invalidated-instance instance)) + ;;;; 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)) - #'(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)))))) @@ -504,20 +534,39 @@ (defmethod unbound-value ((class proxy-class) &rest args) (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 - (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 @@ -562,6 +611,15 @@ (defmethod compute-foreign-size ((class struct-class)) (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) ()) @@ -574,6 +632,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 @@ -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 - #'(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))