From: Dmitry Kalyanov Date: Thu, 12 Feb 2009 21:59:59 +0000 (+0300) Subject: Fixed to memory management X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ba11f152e513f7e2b2b422518cc261669f55ed5e;p=cl-gtk2.git Fixed to memory management --- diff --git a/glib/glib.asd b/glib/glib.asd index 1aea310..ac24eae 100644 --- 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 --- 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 --- 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 --- 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