From 09f6e23711ab7b3b8f713f0cabdaeffcc7c4ac20 Mon Sep 17 00:00:00 2001 Message-Id: <09f6e23711ab7b3b8f713f0cabdaeffcc7c4ac20.1714245699.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sat, 4 Feb 2006 12:15:31 +0000 Subject: [PATCH] Code clean up and propper computation of foreign object sizes Organization: Straylight/Edgeware From: espen --- glib/gboxed.lisp | 4 +- glib/genums.lisp | 4 +- glib/gobject.lisp | 12 +++-- glib/gtype.lisp | 16 +++--- glib/proxy.lisp | 121 ++++++++++++++++++++++++++-------------------- 5 files changed, 89 insertions(+), 68 deletions(-) diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp index 92b4f19..78fd62b 100644 --- a/glib/gboxed.lisp +++ b/glib/gboxed.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: gboxed.lisp,v 1.19 2005-04-23 16:48:50 espen Exp $ +;; $Id: gboxed.lisp,v 1.20 2006-02-04 12:15:31 espen Exp $ (in-package "GLIB") @@ -30,7 +30,7 @@ (defclass boxed (struct) (:metaclass struct-class)) (defmethod instance-finalizer ((instance boxed)) - (let ((location (proxy-location instance)) + (let ((location (foreign-location instance)) (type-number (type-number-of instance))) #'(lambda () (remove-cached-instance location) diff --git a/glib/genums.lisp b/glib/genums.lisp index 64dbc0e..8095b90 100644 --- a/glib/genums.lisp +++ b/glib/genums.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: genums.lisp,v 1.14 2005-04-24 13:24:41 espen Exp $ +;; $Id: genums.lisp,v 1.15 2006-02-04 12:15:32 espen Exp $ (in-package "GLIB") @@ -276,7 +276,7 @@ (defun %query-enum-or-flags-values (query-function class type) (multiple-value-bind (sap length) (funcall query-function (type-class-ref type)) (let ((values nil) - (size (proxy-instance-size (find-class class))) + (size (foreign-size (find-class class))) (proxy (make-instance class :location sap))) (dotimes (i length) (with-slots (location nickname value) proxy diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 0b01d2e..b1c4351 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.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: gobject.lisp,v 1.41 2006-02-03 12:44:32 espen Exp $ +;; $Id: gobject.lisp,v 1.42 2006-02-04 12:15:32 espen Exp $ (in-package "GLIB") @@ -64,6 +64,10 @@ (defbinding %object-unref () nil #+glib2.8 (progn (defcallback toggle-ref-callback (nil (data pointer) (location pointer) (last-ref-p boolean)) + #+debug-ref-counting + (if last-ref-p + (format t "Object at 0x~8,'0X has no foreign references~%" (sap-int location)) + (format t "Foreign reference added to object at 0x~8,'0X~%" (sap-int location))) (if last-ref-p (cache-instance (find-cached-instance location) t) (cache-instance (find-cached-instance location) nil))) @@ -223,7 +227,7 @@ (defun initial-apply-add (object function initargs key pkey) (defmethod initialize-instance :around ((object gobject) &rest initargs) (declare (ignore initargs)) (call-next-method) - #+debug-ref-counting(%object-weak-ref (proxy-location object)) + #+debug-ref-counting(%object-weak-ref (foreign-location object)) #+glib2.8 (when (slot-value (class-of object) 'instance-slots-p) (with-slots (location) object @@ -281,7 +285,7 @@ (defmethod initialize-instance ((object gobject) &rest initargs) (defmethod instance-finalizer ((instance gobject)) - (let ((location (proxy-location instance))) + (let ((location (foreign-location instance))) #+glib2.8 (if (slot-value (class-of instance) 'instance-slots-p) #'(lambda () @@ -526,7 +530,7 @@ (defmethod from-alien-form (form (type (eql 'referenced)) &rest args) (let ((instance (make-symbol "INSTANCE"))) `(let ((,instance ,(from-alien-form form type))) (when ,instance - (%object-unref (proxy-location ,instance))) + (%object-unref (foreign-location ,instance))) ,instance)) (error "~A is not a subclass of GOBJECT" type)))) diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 6b9d31e..2a746e2 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.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: gtype.lisp,v 1.37 2006-02-02 17:56:09 espen Exp $ +;; $Id: gtype.lisp,v 1.38 2006-02-04 12:15:32 espen Exp $ (in-package "GLIB") @@ -282,6 +282,9 @@ (defclass ginstance-class (proxy-class) ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype)))) +(defmethod compute-foreign-size ((class ginstance-class)) + (type-instance-size (find-type-number (class-name class)))) + (defmethod finalize-inheritance ((class ginstance-class)) (call-next-method) (let* ((class-name (class-name class)) @@ -297,10 +300,7 @@ (default-alien-type-name class-name))) (register-new-type class-name (class-name super) gtype))))) (unless (eq (class-name super) (supertype type-number)) (warn "~A is the super type for ~A in the gobject type system." - (supertype type-number) class-name)) - - (unless (slot-boundp class 'size) - (setf (slot-value class 'size) (type-instance-size type-number))))) + (supertype type-number) class-name)))) (defmethod validate-superclass ((class ginstance-class) (super standard-class)) @@ -311,8 +311,10 @@ (defmethod validate-superclass ((class ginstance-class) (super standard-class)) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass ginstance (proxy) - ((class :allocation :alien :type pointer)) - (:metaclass proxy-class))) + (;(class :allocation :alien :type pointer :offset 0) + ) + (:metaclass proxy-class) + (:size #.(size-of 'pointer)))) (defun %type-number-of-ginstance (location) (let ((class (sap-ref-sap location 0))) diff --git a/glib/proxy.lisp b/glib/proxy.lisp index 927e539..994e880 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.23 2006-02-02 22:35:14 espen Exp $ +;; $Id: proxy.lisp,v 1.24 2006-02-04 12:15:32 espen Exp $ (in-package "GLIB") @@ -103,7 +103,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (setq reader (mkbinding getter (slot-definition-type slotd) 'pointer))) - (funcall reader (proxy-location object)))))))))) + (funcall reader (foreign-location object)))))))))) (setf (slot-value slotd 'boundp-function) @@ -124,7 +124,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (setq reader (mkbinding boundp (slot-definition-type slotd) 'pointer))) - (funcall reader (proxy-location object)))))))) + (funcall reader (foreign-location object)))))))) ((multiple-value-bind (unbound-p unbound-value) (unbound-value (slot-definition-type slotd)) (when unbound-p @@ -181,7 +181,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (setq writer (mkbinding setter 'nil 'pointer (slot-definition-type slotd)))) - (funcall writer (proxy-location object) value))))))))) + (funcall writer (foreign-location object) value))))))))) (initialize-internal-slot-gfs (slot-definition-name slotd))) @@ -239,7 +239,7 @@ (defvar *instance-cache* (make-hash-table :test #'eql)) (defun cache-instance (instance &optional (weak-ref t)) (setf - (gethash (sap-int (proxy-location instance)) *instance-cache*) + (gethash (sap-int (foreign-location instance)) *instance-cache*) (if weak-ref (make-weak-pointer instance) instance))) @@ -271,7 +271,7 @@ (defun list-cached-instances () ;;;; Proxy for alien instances (defclass proxy () - ((location :allocation :special :reader proxy-location :type system-area-pointer)) + ((location :allocation :special :reader foreign-location :type pointer)) (:metaclass virtual-slots-class)) (defgeneric instance-finalizer (object)) @@ -286,17 +286,13 @@ (defmethod unreference-foreign ((name symbol) location) (defmethod unreference-foreign :around ((class class) location) (unless (null-pointer-p location) -;; (format t "Unreferencing ~A at ~A" (class-name class) location) -;; (finish-output *standard-output*) - (call-next-method) -;; (write-line " done") -;; (finish-output *standard-output*) - )) + (call-next-method))) (defmethod print-object ((instance proxy) stream) (print-unreadable-object (instance stream :type t :identity nil) - (when (slot-boundp instance 'location) - (format stream "at 0x~X" (sap-int (proxy-location instance)))))) + (if (slot-boundp instance 'location) + (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 @@ -307,7 +303,7 @@ (defmethod initialize-instance :around ((instance proxy) &key location) instance) (defmethod instance-finalizer ((instance proxy)) - (let ((location (proxy-location instance)) + (let ((location (foreign-location instance)) (class (class-of instance))) ;; (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil) ;; (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class)) @@ -320,11 +316,12 @@ (defmethod instance-finalizer ((instance proxy)) (defgeneric most-specific-proxy-superclass (class)) (defgeneric direct-proxy-superclass (class)) +(defgeneric compute-foreign-size (class)) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass proxy-class (virtual-slots-class) - ((size :reader proxy-instance-size))) + ((size :reader foreign-size))) (defclass direct-alien-slot-definition (direct-virtual-slot-definition) ((allocation :initform :alien) @@ -350,7 +347,7 @@ (defmethod shared-initialize ((class proxy-class) names &key size) (cond (size (setf (slot-value class 'size) (first size))) ((slot-boundp class 'size) (slot-makunbound class 'size)))) - + (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs) (case (getf initargs :allocation) (:alien (find-class 'direct-alien-slot-definition)) @@ -378,7 +375,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-def (setf (slot-value slotd 'getter) #'(lambda (object) - (funcall reader (proxy-location object) offset))))) + (funcall reader (foreign-location object) offset))))) (unless (slot-boundp slotd 'setter) (let ((writer (writer-function type)) @@ -386,50 +383,58 @@ (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-def (setf (slot-value slotd 'setter) #'(lambda (value object) - (let ((location (proxy-location object))) + (let ((location (foreign-location object))) (funcall destroy location offset) ; destroy old value (funcall writer value location offset)))))))) (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) + (defun align-offset (size) + (if (zerop (mod size +struct-alignmen+)) + size + (+ size (- +struct-alignmen+ (mod size +struct-alignmen+))))) + (defmethod compute-slots ((class proxy-class)) - (loop - with offset = (let ((size-of-super-classes - (proxy-instance-size - (most-specific-proxy-superclass class)))) - (+ size-of-super-classes - (mod size-of-super-classes +struct-alignmen+))) - with size = offset - for slotd in (class-direct-slots class) - when (eq (slot-definition-allocation slotd) :alien) - do (if (not (slot-boundp slotd 'offset)) - (setf (slot-value slotd 'offset) offset) - (setq offset (slot-value slotd 'offset))) - - (incf offset (size-of (slot-definition-type slotd))) - (incf offset (mod offset +struct-alignmen+)) - (setq size (max size offset)) - - finally (unless (slot-boundp class 'size) - (setf (slot-value class 'size) size))) + (let ((alien-slots + (remove-if-not + #'(lambda (slotd) + (eq (slot-definition-allocation slotd) :alien)) + (class-direct-slots class)))) + (when alien-slots + (loop + as offset = (align-offset (foreign-size + (most-specific-proxy-superclass class))) + then (align-offset + (+ + (slot-definition-offset slotd) + (size-of (slot-definition-type slotd)))) + for slotd in alien-slots + unless (slot-boundp slotd 'offset) + 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 proxy-instance-size (class) - (declare (ignore class)) - 0) + (defmethod foreign-size ((class-name symbol)) + (foreign-size (find-class class-name)))) - (defmethod proxy-instance-size ((class-name symbol)) - (proxy-instance-size (find-class class-name))) -) +(defmethod foreign-size ((object proxy)) + (foreign-size (class-of object))) + (defmethod alien-type ((class proxy-class) &rest args) (declare (ignore class args)) (alien-type 'pointer)) @@ -449,11 +454,11 @@ (defmethod from-alien-function ((class proxy-class) &rest args) (defmethod to-alien-form (instance (class proxy-class) &rest args) (declare (ignore class args)) - `(proxy-location ,instance)) + `(foreign-location ,instance)) (defmethod to-alien-function ((class proxy-class) &rest args) (declare (ignore class args)) - #'proxy-location) + #'foreign-location) (defmethod copy-from-alien-form (location (class proxy-class) &rest args) (declare (ignore args)) @@ -468,12 +473,12 @@ (defmethod copy-from-alien-function ((class proxy-class) &rest args) (defmethod copy-to-alien-form (instance (class proxy-class) &rest args) (declare (ignore args)) - `(reference-foreign ',(class-name class) (proxy-location ,instance))) + `(reference-foreign ',(class-name class) (foreign-location ,instance))) (defmethod copy-to-alien-function ((class proxy-class) &rest args) (declare (ignore args)) #'(lambda (instance) - (reference-foreign class (proxy-location instance)))) + (reference-foreign class (foreign-location instance)))) (defmethod writer-function ((class proxy-class) &rest args) (declare (ignore args)) @@ -481,7 +486,7 @@ (defmethod writer-function ((class proxy-class) &rest args) (assert (null-pointer-p (sap-ref-sap location offset))) (setf (sap-ref-sap location offset) - (reference-foreign class (proxy-location instance))))) + (reference-foreign class (foreign-location instance))))) (defmethod reader-function ((class proxy-class) &rest args) (declare (ignore args)) @@ -519,12 +524,13 @@ (defmethod ensure-proxy-instance ((class proxy-class) location) (defclass struct (proxy) () - (:metaclass proxy-class)) + (:metaclass proxy-class) + (:size 0)) (defmethod initialize-instance ((struct struct) &rest initargs) (declare (ignore initargs)) (unless (slot-boundp struct 'location) - (let ((size (proxy-instance-size (class-of struct)))) + (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))))) @@ -542,11 +548,20 @@ (defmethod direct-slot-definition-class ((class struct-class) &rest initargs) (call-next-method))) (defmethod reference-foreign ((class struct-class) location) - (copy-memory location (proxy-instance-size class))) + (copy-memory location (foreign-size class))) (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+)))) + (defclass static-struct-class (struct-class) ()) @@ -564,7 +579,7 @@ (defmethod unreference-foreign ((class static-struct-class) location) (defmethod size-of ((type (eql 'inlined)) &rest args) (declare (ignore type)) - (proxy-instance-size (first args))) + (foreign-size (first args))) (defmethod reader-function ((type (eql 'inlined)) &rest args) (declare (ignore type)) -- [mdw]