Use 'toggle references'; remove custom denaturation-fighting code from subclassing

diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp
index b197b5f..a68add0 100644 (file)
--- a/glib/gobject.foreign-gobject-subclassing.lisp
+++ b/glib/gobject.foreign-gobject-subclassing.lisp
@@ -4,32 +4,17 @@
 
 (defstruct object-type name class parent interfaces properties)
 
-(defvar *lisp-objects-references* (make-hash-table :test 'equal))
-
-(defun object-toggle-pointer (data object is-last-ref)
-  (declare (ignore data))
-  (debugf "Toggling pointer on ~a (~A) to being ~A~%" object (gethash (pointer-address object) *lisp-objects-references*) (if is-last-ref "last ref" "not last ref"))
-  (if is-last-ref
-      (remhash (pointer-address object) *lisp-objects-references*)
-      (setf (gethash (pointer-address object) *lisp-objects-references*) (gethash (pointer-address object) *foreign-gobjects*))))
-
 (defun instance-init (instance class)
   (debugf "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class :type)) *current-creating-object*)
-  (unless (gethash (pointer-address instance) *lisp-objects-pointers*)
+  (unless (or *current-creating-object*
+              (gethash (pointer-address instance) *foreign-gobjects-strong*)
+              (gethash (pointer-address instance) *foreign-gobjects-weak*))
     (debugf "  Proceeding with initialization...")
-    (setf (gethash (pointer-address instance) *lisp-objects-pointers*) t
-          (gethash (pointer-address instance) *lisp-objects-references*)
-          (or *current-creating-object*
-              (let* ((g-type (foreign-slot-value class 'g-type-class :type))
-                     (type-name (g-type-name g-type))
-                     (lisp-type-info (gethash type-name *registered-types*))
-                     (lisp-class (object-type-class lisp-type-info)))
-                (make-instance lisp-class :pointer instance))))
-    (g-object-add-toggle-ref instance (callback c-object-toggle-pointer) (null-pointer))
-    (g-object-unref instance)))
-
-(defcallback c-object-toggle-pointer :void ((data :pointer) (object :pointer) (is-last-ref :boolean))
-  (object-toggle-pointer data object is-last-ref))
+    (let* ((g-type (foreign-slot-value class 'g-type-class :type))
+           (type-name (g-type-name g-type))
+           (lisp-type-info (gethash type-name *registered-types*))
+           (lisp-class (object-type-class lisp-type-info)))
+      (make-instance lisp-class :pointer instance))))
 
 (defcallback c-instance-init :void ((instance :pointer) (class :pointer))
   (instance-init instance class))
@@ -161,7 +146,8 @@
 
 (defun object-property-get (object property-id g-value pspec)
   (declare (ignore property-id))
-  (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
+  (let* ((lisp-object (or (gethash (pointer-address object) *foreign-gobjects-strong*)
+                          (gethash (pointer-address object) *foreign-gobjects-weak*)))
          (property-name (foreign-slot-value pspec 'g-param-spec :name))
          (property-type (foreign-slot-value pspec 'g-param-spec :value-type))
          (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
@@ -179,7 +165,8 @@
 
 (defun object-property-set (object property-id value pspec)
   (declare (ignore property-id))
-  (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
+  (let* ((lisp-object (or (gethash (pointer-address object) *foreign-gobjects-strong*)
+                          (gethash (pointer-address object) *foreign-gobjects-weak*)))
          (property-name (foreign-slot-value pspec 'g-param-spec :name))
          (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
          (lisp-type-info (gethash type-name *registered-types*))

diff --git a/glib/gobject.object.high.lisp b/glib/gobject.object.high.lisp
index a7b4451..38926b4 100644 (file)
--- a/glib/gobject.object.high.lisp
+++ b/glib/gobject.object.high.lisp
@@ -13,9 +13,8 @@
   (:documentation
    "Base class for GObject classes hierarchy."))
 
-(defvar *foreign-gobjects* (make-weak-hash-table :test 'equal :weakness :value))
-(defvar *foreign-gobjects-ref-count* (make-hash-table :test 'equal))
-(defvar *lisp-objects-pointers* (make-hash-table :test 'equal))
+(defvar *foreign-gobjects-weak* (make-weak-hash-table :test 'equal :weakness :value))
+(defvar *foreign-gobjects-strong* (make-hash-table :test 'equal))
 (defvar *current-creating-object* nil)
 
 (defun ref-count (pointer)
@@ -32,6 +31,7 @@
          (s (format nil "~A" obj)))
     (finalize obj
               (lambda ()
+                (debugf "~A is queued for GC (having ~A refs)~%" pointer (ref-count pointer))
                 (handler-case
                     (g-object-dispose-carefully pointer)
                   (error (e) (format t "Error in finalizer for ~A: ~A~%" s e))))))
@@ -47,7 +47,7 @@
       (debugf "activating gc hooks for objects: ~A~%" *gobject-gc-hooks*)
       (loop
          for pointer in *gobject-gc-hooks*
-         do (g-object-unref pointer))
+         do (g-object-remove-toggle-ref pointer (callback gobject-toggle-ref-toggled) (null-pointer)))
       (setf *gobject-gc-hooks* nil))))
 
 (defcallback g-idle-gc-hook :boolean ((data :pointer))
@@ -68,67 +68,54 @@
       (register-gobject-for-gc pointer)
     (error (e) (format t "Error in dispose: ~A~%" e))))
 
-(defcallback weak-notify-print :void ((data :pointer) (object-pointer :pointer))
-  (declare (ignore data)
-           (ignorable object-pointer))
-  (debugf "g-object has finalized ~A ~A~%" (g-type-name (g-type-from-object object-pointer)) object-pointer))
-
-(defun erase-pointer (data object-pointer)
-  (declare (ignore data))
-  (remhash (pointer-address object-pointer) *lisp-objects-pointers*))
-
-(defcallback weak-notify-erase-pointer :void ((data :pointer) (object-pointer :pointer))
-  (erase-pointer data object-pointer))
-
 (defun should-ref-sink-at-creation (object)
 ;;If object was not created from lisp-side, we should ref it
 ;;If an object is regular g-object, we should not ref-sink it
 ;;If an object is GInitiallyUnowned, then it is created with a floating reference, we should ref-sink it
 ;;A special case is GtkWindow: we should ref-sink it anyway
-  (if (g-object-has-reference object)
-      (let ((object-type (g-type-from-object (pointer object)))
-            (initially-unowned-type (g-type-from-name "GInitiallyUnowned")))
-        (g-type-is-a object-type initially-unowned-type))
-      t))
+  (let ((r (cond
+             ((eq object *current-creating-object*)  ;; g_object_new returns objects with ref = 1, we should save _this_ ref
+              (g-object-is-floating (pointer object))) ;; but floating objects should be ref_sunk
+             (t t))))
+    (debugf "(should-ref-sink-at-creation ~A) => ~A~%" object r)
+    r))
+
+(defcallback gobject-toggle-ref-toggled :void
+    ((data :pointer) (pointer :pointer) (is-last-ref :boolean))
+  (declare (ignore data))
+  (debugf "~A is now ~A with ~A refs~%" pointer (if is-last-ref "weak pointer" "strong pointer") (ref-count pointer))
+  (debugf "obj: ~A~%" (or (gethash (pointer-address pointer) *foreign-gobjects-strong*)
+                            (gethash (pointer-address pointer) *foreign-gobjects-weak*)))
+  (if is-last-ref
+      (let ((obj (gethash (pointer-address pointer) *foreign-gobjects-strong*)))
+        (if obj
+            (progn
+              (remhash (pointer-address pointer) *foreign-gobjects-strong*)
+              (setf (gethash (pointer-address pointer) *foreign-gobjects-weak*) obj))
+            (warn "GObject at ~A has no lisp-side (strong) reference" pointer)))
+      (let ((obj (gethash (pointer-address pointer) *foreign-gobjects-weak*)))
+        (unless obj (warn "GObject at ~A has no lisp-side (weak) reference" pointer))
+        (remhash (pointer-address pointer) *foreign-gobjects-weak*)
+        (setf (gethash (pointer-address pointer) *foreign-gobjects-strong*) obj))))
+
+(defcallback gobject-weak-ref-finalized :void
+    ((data :pointer) (pointer :pointer))
+  (declare (ignore data))
+  (debugf "~A is weak-ref-finalized with ~A refs~%" pointer (ref-count pointer))
+  (remhash (pointer-address pointer) *foreign-gobjects-weak*)
+  (when (gethash (pointer-address pointer) *foreign-gobjects-strong*)
+    (warn "GObject at ~A was weak-ref-finalized while still holding lisp-side strong reference to it" pointer))
+  (remhash (pointer-address pointer) *foreign-gobjects-strong*))
 
 (defun register-g-object (obj)
   (debugf "registered GObject ~A with gobject ref-count ~A ~A~%" (pointer obj) (ref-count obj) (if (g-object-is-floating (pointer obj)) "(floating)" ""))
   (when (should-ref-sink-at-creation obj)
     (debugf "g_object_ref_sink(~A)~%" (pointer obj))
     (g-object-ref-sink (pointer obj)))
-  (g-object-weak-ref (pointer obj) (callback weak-notify-print) (null-pointer))
-  (g-object-weak-ref (pointer obj) (callback weak-notify-erase-pointer) (null-pointer))
   (setf (g-object-has-reference obj) t)
-  (setf (gethash (pointer-address (pointer obj)) *foreign-gobjects*)
-        obj)
-  (setf (gethash (pointer-address (pointer obj)) *foreign-gobjects-ref-count*) 1))
-
-(defun g-object-dispose (pointer)
-  (unless (gethash (pointer-address pointer) *foreign-gobjects-ref-count*)
-    (debugf "GObject ~A is already disposed, signalling error~%" pointer)
-    (error "GObject ~A is already disposed" pointer))
-  (debugf "g_object_unref(~A) (of type ~A, lisp-value ~A) (lisp ref-count ~A, gobject ref-count ~A)~%"
-          pointer
-          (g-type-name (g-type-from-object pointer))
-          (gethash (pointer-address pointer) *foreign-gobjects*)
-          (gethash (pointer-address pointer) *foreign-gobjects-ref-count*)
-          (ref-count pointer))
-  (let ((object (gethash (pointer-address pointer) *foreign-gobjects*)))
-    (when object
-      (setf (pointer object) nil)
-      (cancel-finalization object)))
-  (remhash (pointer-address pointer) *foreign-gobjects*)
-  (remhash (pointer-address pointer) *foreign-gobjects-ref-count*)
-  (g-object-unref pointer))
-
-(defmethod release ((object g-object))
-  (debugf "Releasing object ~A (type ~A, lisp-value ~A)~%" (pointer object) (when (pointer object) (g-type-name (g-type-from-object (pointer object)))) object)
-  (unless (and (pointer object) (gethash (pointer-address (pointer object)) *foreign-gobjects-ref-count*))
-    (error "Object ~A already disposed of from lisp side" object))
-  (decf (gethash (pointer-address (pointer object)) *foreign-gobjects-ref-count*))
-  (when (zerop (gethash (pointer-address (pointer object)) *foreign-gobjects-ref-count*))
-    (g-object-dispose (pointer object)))
-  (activate-gc-hooks))
+  (setf (gethash (pointer-address (pointer obj)) *foreign-gobjects-strong*) obj)
+  (g-object-add-toggle-ref (pointer obj) (callback gobject-toggle-ref-toggled) (null-pointer))
+  (g-object-unref (pointer obj)))
 
 (defvar *registered-object-types* (make-hash-table :test 'equal))
 (defun register-object-type (name type)
@@ -175,12 +162,9 @@
 
 (defun get-g-object-for-pointer (pointer)
   (unless (null-pointer-p pointer)
-    (let ((object (gethash (pointer-address pointer) *foreign-gobjects*)))
-      (if object
-          (prog1 object
-            (incf (gethash (pointer-address pointer) *foreign-gobjects-ref-count*))
-            (debugf "increfering object ~A~%" pointer))
-          (make-g-object-from-pointer pointer)))))
+    (or (gethash (pointer-address pointer) *foreign-gobjects-strong*)
+        (gethash (pointer-address pointer) *foreign-gobjects-weak*)
+        (make-g-object-from-pointer pointer))))
 
 (defmethod translate-from-foreign (pointer (type foreign-g-object-type))
   (get-g-object-for-pointer pointer))