Fixed to memory management

diff --git a/glib/glib.asd b/glib/glib.asd
index 1aea310..ac24eae 100644 (file)
--- a/glib/glib.asd
+++ b/glib/glib.asd
@@ -24,4 +24,4 @@
                (:file "gobject.gobject-query")
                (:file "gobject.generating")
                (:file "gobject.object-defs"))
-  :depends-on (:cffi :trivial-garbage :metabang-bind :iterate :anaphora))
\ No newline at end of file
+  :depends-on (:cffi :trivial-garbage :metabang-bind :iterate :anaphora :bordeaux-threads))
\ No newline at end of file

diff --git a/glib/gobject.foreign-gboxed.lisp b/glib/gobject.foreign-gboxed.lisp
index 712e3e0..1cd1ffc 100644 (file)
--- a/glib/gobject.foreign-gboxed.lisp
+++ b/glib/gobject.foreign-gboxed.lisp
@@ -209,6 +209,8 @@
   (debugf "disposing g-boxed-ref ~A~%" pointer)
   (unless (gethash (pointer-address pointer) *boxed-ref-count*)
     (error "g-boxed-ref ~A is already disposed from lisp-side" pointer))
+  ;;This actually turned out to be wrong
+  #+(or)
   (unless (zerop (gethash (pointer-address pointer) *boxed-ref-count*))
     (error "g-boxed-ref ~A is being disposed too early, it has still ~A references from lisp-side"
            (pointer-address pointer)
@@ -224,9 +226,12 @@
   (setf (gethash (pointer-address (pointer object)) *boxed-ref-count*) 1)
   (debugf "setting g-boxed-ref-count of ~A to 1~%" (pointer object))
   (let ((p (pointer object))
-        (type (type-of object)))
-    (tg:finalize object (lambda ()
-                          (dispose-boxed-ref type p)))))
+        (type (type-of object))
+        (s (format nil "~A" object)))
+    (tg:finalize object (lambda ()                          
+                          (handler-case
+                              (dispose-boxed-ref type p)
+                            (error (e) (format t "Error ~A for ~A~%" e s)))))))
 
 (defmethod release ((object g-boxed-ref))
   (debugf "releasing g-boxed-ref ~A~%" (pointer object))

diff --git a/glib/gobject.foreign-gobject.lisp b/glib/gobject.foreign-gobject.lisp
index ce17283..a84c6b3 100644 (file)
--- a/glib/gobject.foreign-gobject.lisp
+++ b/glib/gobject.foreign-gobject.lisp
@@ -25,20 +25,64 @@
 (defmethod initialize-instance :after ((obj g-object) &key &allow-other-keys)
   (unless (slot-boundp obj 'pointer)
     (error "Pointer slot is not initialized for ~A" obj))
-  (let ((pointer (pointer obj)))
-    #+ (or) (finalize obj
+  (let* ((pointer (pointer obj))
+         (s (format nil obj)))
+    (finalize obj
               (lambda ()
-                (g-object-dispose pointer))))
-  (register-g-object obj))
+                (handler-case
+                    (g-object-dispose-carefully pointer)
+                  (error (e) (format t "Error in finalizer for ~A: ~A~%" s e))))))
+  (register-g-object obj)
+  (activate-gc-hooks))
+
+(defvar *gobject-gc-hooks-lock* (make-recursive-lock "gobject-gc-hooks-lock"))
+(defvar *gobject-gc-hooks* nil);;pointers to objects to be freed
+
+(defun activate-gc-hooks ()
+  (with-recursive-lock-held (*gobject-gc-hooks-lock*)
+    (when *gobject-gc-hooks*
+      (debugf "activating gc hooks for objects: ~A~%" *gobject-gc-hooks*)
+      (loop
+         for pointer in *gobject-gc-hooks*
+         do (g-object-unref pointer))
+      (setf *gobject-gc-hooks* nil))))
+
+(defcallback g-idle-gc-hook :boolean ((data :pointer))
+  (declare (ignore data))
+  (activate-gc-hooks)
+  nil)
+
+(defun register-gobject-for-gc (pointer)
+  (with-recursive-lock-held (*gobject-gc-hooks-lock*)
+    (let ((locks-were-present (not (null *gobject-gc-hooks*))))
+      (push pointer *gobject-gc-hooks*)
+      (unless locks-were-present
+        (debugf "adding idle-gc-hook to main loop~%")
+        (glib::g-idle-add (callback g-idle-gc-hook) (null-pointer))))))
+
+(defun g-object-dispose-carefully (pointer)
+  (handler-case
+      (register-gobject-for-gc pointer)
+    (error (e) (format t "Error in dispose: ~A~%" e))))
 
 (defcallback weak-notify-print :void ((data :pointer) (object-pointer :pointer))
-  (debugf "g-object has disposed ~A ~A~%" (g-type-name (g-type-from-object object-pointer)) object-pointer))
+  (declare (ignore data))
+  (debugf "g-object has finalized ~A ~A~%" (g-type-name (g-type-from-object object-pointer)) 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))
 
 (defun register-g-object (obj)
-  (debugf "registered GObject ~A with ref-count ~A~%" (pointer obj) (ref-count obj))
-  (when (or t ;; Do not understand
-            (not (g-object-has-reference obj))
-            (g-object-is-floating (pointer obj)))
+  (debugf "registered GObject ~A with 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))
@@ -48,6 +92,9 @@
   (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*)
+    (format t "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))
@@ -67,7 +114,8 @@
     (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))))
+    (g-object-dispose (pointer object)))
+  (activate-gc-hooks))
 
 (defvar *registered-object-types* (make-hash-table :test 'equal))
 (defun register-object-type (name type)

diff --git a/glib/gobject.package.lisp b/glib/gobject.package.lisp
index 5314ebf..cbc7dda 100644 (file)
--- a/glib/gobject.package.lisp
+++ b/glib/gobject.package.lisp
@@ -1,5 +1,5 @@
 (defpackage :gobject
-  (:use :cl :glib :cffi :tg :bind :anaphora)
+  (:use :cl :glib :cffi :tg :bind :anaphora :bordeaux-threads)
   (:export #:g-object
            #:register-object-type
            #:g-object-call-constructor