Strongly reference live dynamic objects

call.lisp

@@ -31,10 +31,10 @@
 (named-readtables:in-readtable :qt)
 
 (defun pointer->cached-object (ptr)
-  (gethash (cffi:pointer-address ptr) *cached-objects*))
+  (gethash (cffi:pointer-address ptr) *weakly-cached-objects*))
 
 (defun (setf pointer->cached-object) (newval ptr)
-  (setf (gethash (cffi:pointer-address ptr) *cached-objects*)
+  (setf (gethash (cffi:pointer-address ptr) *weakly-cached-objects*)
         newval))
 
 (defun %deletion-callback (obj)
@@ -711,7 +711,9 @@
   (check-type object abstract-qobject)
   (unless (qobject-deleted object)
     (cancel-finalization object)
-    (remhash (cffi:pointer-address (qobject-pointer object)) *cached-objects*)
+    (let ((addr (cffi:pointer-address (qobject-pointer object))))
+      (remhash addr *weakly-cached-objects*)
+      (remhash addr *strongly-cached-objects*))
     (setf (qobject-deleted object) t)))
 
 (defun cancel-finalization (object)

info.lisp

@@ -842,7 +842,8 @@
 ;;;; Startup stuff
 
 
-(defvar *cached-objects*)
+(defvar *weakly-cached-objects*)
+(defvar *strongly-cached-objects*)
 (defvar *keep-alive*)
 (defvar *qobject-metaobject* nil)
 (defvar *smoke-instance-list* (list nil nil))
@@ -852,8 +853,8 @@
   (setf *n-modules* 0)
   (fill *module-table* nil)
   (fill *module-data-table* nil)
-  (setf *cached-objects* (tg:make-weak-hash-table :weakness :value))
-  ;; (setf *cached-objects* (make-hash-table))
+  (setf *weakly-cached-objects* (tg:make-weak-hash-table :weakness :value))
+  (setf *strongly-cached-objects* (make-hash-table))
   (setf *keep-alive* (make-hash-table))
   (setf *qobject-metaobject* nil)
   (unless *library-loaded-p*

meta.lisp

@@ -100,9 +100,16 @@
        (warn "Bug in CommonQt?  ~A still has parent ~A; not deleting"
              object parent)))))
 
+(defclass dynamic-object (qobject)
+  ())
+
 (defun cache! (object)
-  (assert (null (pointer->cached-object (qobject-pointer object))))
-  (setf (pointer->cached-object (qobject-pointer object)) object)
+  (let ((ptr (qobject-pointer object)))
+    (assert (null (pointer->cached-object ptr)))
+    (setf (pointer->cached-object ptr) object)
+    (when (typep object 'dynamic-object)
+      (setf (gethash (cffi:pointer-address ptr) *strongly-cached-objects*)
+            object)))
   (when (and *report-memory-leaks*
              (or (not (qtypep object (find-qclass "QObject")))
                  (typep (#_parent object) 'null-qobject)))
@@ -129,9 +136,6 @@
   ((function :initarg :function
              :accessor dynamic-member-function)))
 
-(defclass dynamic-object (qobject)
-  ())
-
 (defmethod print-object ((instance dynamic-object) stream)
   (print-unreadable-object (instance stream :type t :identity nil)
     (cond
@@ -337,7 +341,7 @@
       qt-class
     (unless (and qmetaobject
 		 effective-class
-		 (eq smoke-generation *cached-objects*))
+		 (eq smoke-generation *weakly-cached-objects*))
       ;; clear everything out to ensure a clean state in case of errors
       ;; in the following forms
       (setf effective-class nil)
@@ -370,7 +374,7 @@
       ;; invalidate call site caches
       (setf generation (gensym))
       ;; mark as fresh
-      (setf (class-smoke-generation qt-class) *cached-objects*))))
+      (setf (class-smoke-generation qt-class) *weakly-cached-objects*))))
 
 (defun convert-dynamic-member (member)
   (make-slot-or-signal (dynamic-member-name member)))