Further work to improve Object reference accounting in order to plug leaks.

3 files changed, 188 insertions, 107 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index a129a52..83646a8 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -426,17 +426,17 @@ InitFoundation(
 
     /* Rewire bootstrapped objects. */
     fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
-    AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr);
+    AddRef(fPtr->classCls->thisPtr);
+    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
 
     fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
-    AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr);
+    AddRef(fPtr->classCls->thisPtr);
+    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
 
     fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
     fPtr->classCls->flags |= ROOT_CLASS;
 
     /* Standard initialization for new Objects */
-    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
-    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
     TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
 
     /*
@@ -568,12 +568,6 @@ KillFoundation(
     TclDecrRefCount(fPtr->destructorName);
     TclDecrRefCount(fPtr->clonedName);
     TclDecrRefCount(fPtr->defineName);
-    if (fPtr->objectCls->thisPtr->selfCls != NULL) {
-	TclOODecrRefCount(fPtr->objectCls->thisPtr->selfCls->thisPtr);
-    }
-    if (fPtr->classCls->thisPtr->selfCls != NULL) {
-	TclOODecrRefCount(fPtr->classCls->thisPtr->selfCls->thisPtr);
-    }
     TclOODecrRefCount(fPtr->objectCls->thisPtr);
     TclOODecrRefCount(fPtr->classCls->thisPtr);
 
@@ -660,6 +654,9 @@ AllocObject(
 	Tcl_ResetResult(interp);
     }
 
+
+  configNamespace:
+
     ((Namespace *)oPtr->namespacePtr)->refCount++;
 
     /*
@@ -667,7 +664,6 @@ AllocObject(
      * to the [self] and [next] commands.
      */
 
-  configNamespace:
     if (fPtr->helpersNs != NULL) {
 	TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
     }
@@ -1007,8 +1003,11 @@ ReleaseClassContents(
     if (clsPtr->mixins.num) {
 	FOREACH(tmpClsPtr, clsPtr->mixins) {
 	    TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
+	    TclOODecrRefCount(tmpClsPtr->thisPtr);
 	}
 	ckfree(clsPtr->mixins.list);
+	clsPtr->mixins.list = NULL;
+	clsPtr->mixins.num = 0;
     }
 
     if (clsPtr->superclasses.num > 0) {
@@ -1149,6 +1148,7 @@ ObjectNamespaceDeleted(
     if (oPtr->mixins.num > 0) {
 	FOREACH(mixinPtr, oPtr->mixins) {
 	    TclOORemoveFromInstances(oPtr, mixinPtr);
+	    TclOODecrRefCount(mixinPtr->thisPtr);
 	}
 	ckfree(oPtr->mixins.list);
     }
@@ -1837,16 +1837,22 @@ Tcl_CopyObjectInstance(
      * Copy the object's mixin references to the new object.
      */
 
-    FOREACH(mixinPtr, o2Ptr->mixins) {
-	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
-	    TclOORemoveFromInstances(o2Ptr, mixinPtr);
+    if (o2Ptr->mixins.num != 0) {
+	FOREACH(mixinPtr, o2Ptr->mixins) {
+	    if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
+		TclOORemoveFromInstances(o2Ptr, mixinPtr);
+	    }
+	    TclOODecrRefCount(mixinPtr->thisPtr);
 	}
+	ckfree(o2Ptr->mixins.list);
     }
     DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
     FOREACH(mixinPtr, o2Ptr->mixins) {
 	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
 	    TclOOAddToInstances(o2Ptr, mixinPtr);
 	}
+	/* For the reference just created in DUPLICATE */
+	AddRef(mixinPtr->thisPtr);
     }
 
     /*
@@ -1924,6 +1930,7 @@ Tcl_CopyObjectInstance(
 
 	FOREACH(superPtr, cls2Ptr->superclasses) {
 	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);
+	    TclOODecrRefCount(superPtr->thisPtr);
 	}
 	if (cls2Ptr->superclasses.num) {
 	    cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
@@ -1967,15 +1974,18 @@ Tcl_CopyObjectInstance(
 	 * references to the duplicate).
 	 */
 
-	FOREACH(mixinPtr, cls2Ptr->mixins) {
-	    TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
-	}
 	if (cls2Ptr->mixins.num != 0) {
+	    FOREACH(mixinPtr, cls2Ptr->mixins) {
+		TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
+		TclOODecrRefCount(mixinPtr->thisPtr);
+	    }
 	    ckfree(clsPtr->mixins.list);
 	}
 	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
 	FOREACH(mixinPtr, cls2Ptr->mixins) {
 	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
+	    /* For the copy just created in DUPLICATE */
+	    AddRef(mixinPtr->thisPtr);
 	}
 
 	/*
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index dfd2acf..648ad02 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -327,6 +327,7 @@ TclOOObjectSetMixins(
 	if (oPtr->mixins.num != 0) {
 	    FOREACH(mixinPtr, oPtr->mixins) {
 		TclOORemoveFromInstances(oPtr, mixinPtr);
+		TclOODecrRefCount(mixinPtr->thisPtr);
 	    }
 	    ckfree(oPtr->mixins.list);
 	    oPtr->mixins.num = 0;
@@ -338,6 +339,7 @@ TclOOObjectSetMixins(
 		if (mixinPtr && mixinPtr != oPtr->selfCls) {
 		    TclOORemoveFromInstances(oPtr, mixinPtr);
 		}
+		TclOODecrRefCount(mixinPtr->thisPtr);
 	    }
 	    oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
 		    sizeof(Class *) * numMixins);
@@ -350,10 +352,8 @@ TclOOObjectSetMixins(
 	FOREACH(mixinPtr, oPtr->mixins) {
 	    if (mixinPtr != oPtr->selfCls) {
 		TclOOAddToInstances(oPtr, mixinPtr);
-		/* Corresponding TclOODecrRefCount() is in the caller of this
-		 * function. 
-		 */
-		TclOODecrRefCount(mixinPtr->thisPtr);
+		/* For the new copy created by memcpy */
+		AddRef(mixinPtr->thisPtr);
 	    }
 	}
     }
@@ -383,6 +383,7 @@ TclOOClassSetMixins(
 	if (classPtr->mixins.num != 0) {
 	    FOREACH(mixinPtr, classPtr->mixins) {
 		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+		TclOODecrRefCount(mixinPtr->thisPtr);
 	    }
 	    ckfree(classPtr->mixins.list);
 	    classPtr->mixins.num = 0;
@@ -391,6 +392,7 @@ TclOOClassSetMixins(
 	if (classPtr->mixins.num != 0) {
 	    FOREACH(mixinPtr, classPtr->mixins) {
 		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+		TclOODecrRefCount(mixinPtr->thisPtr);
 	    }
 	    classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
 		    sizeof(Class *) * numMixins);
@@ -401,10 +403,8 @@ TclOOClassSetMixins(
 	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
 	FOREACH(mixinPtr, classPtr->mixins) {
 	    TclOOAddToMixinSubs(classPtr, mixinPtr);
-	    /* Corresponding TclOODecrRefCount() is in the caller of this
-	     * function
-	     */
-	    TclOODecrRefCount(mixinPtr->thisPtr);
+	    /* For the new copy created by memcpy */
+	    AddRef(mixinPtr->thisPtr);
 	}
     }
     BumpGlobalEpoch(interp, classPtr);
@@ -1125,7 +1125,6 @@ TclOODefineClassObjCmd(
      */
 
     if (oPtr->selfCls != clsPtr) {
-
 	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
 	TclOODecrRefCount(oPtr->selfCls->thisPtr);
 	oPtr->selfCls = clsPtr;
@@ -1587,10 +1586,6 @@ TclOODefineMixinObjCmd(
 	    goto freeAndError;
 	}
 	mixins[i-1] = clsPtr;
-	/* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins,
-	 * TclOOClassSetMixinsk, or just below if this function fails.
-	 */
-	AddRef(mixins[i-1]->thisPtr);
     }
 
     if (isInstanceMixin) {
@@ -1603,9 +1598,6 @@ TclOODefineMixinObjCmd(
     return TCL_OK;
 
   freeAndError:
-    while (--i > 0) {
-	TclOODecrRefCount(mixins[i]->thisPtr);
-    }
     TclStackFree(interp, mixins);
     return TCL_ERROR;
 }
@@ -2030,10 +2022,6 @@ ClassMixinSet(
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
 	    goto freeAndError;
 	}
-	/* Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or just
-	 * below if this function fails
-	 */
-	AddRef(mixins[i]->thisPtr);
     }
 
     TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
@@ -2041,9 +2029,6 @@ ClassMixinSet(
     return TCL_OK;
 
   freeAndError:
-    while (i-- > 0) {
-	TclOODecrRefCount(mixins[i]->thisPtr);
-    }
     TclStackFree(interp, mixins);
     return TCL_ERROR;
 }
@@ -2197,6 +2182,7 @@ ClassSuperSet(
     if (oPtr->classPtr->superclasses.num != 0) {
 	FOREACH(superPtr, oPtr->classPtr->superclasses) {
 	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+	    TclOODecrRefCount(superPtr->thisPtr);
 	}
 	ckfree((char *) oPtr->classPtr->superclasses.list);
     }
@@ -2494,16 +2480,9 @@ ObjMixinSet(
 	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
 		"may only mix in classes");
 	if (mixins[i] == NULL) {
-	    while (i-- > 0) {
-		TclOODecrRefCount(mixins[i]->thisPtr);
-	    }
 	    TclStackFree(interp, mixins);
 	    return TCL_ERROR;
 	}
-	/* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or
-	 * just above if this function fails.
-	 */
-	AddRef(mixins[i]->thisPtr);
     }
 
     TclOOObjectSetMixins(oPtr, mixinc, mixins);
diff --git a/tests/oo.test b/tests/oo.test
index a698bac..fbf75b6 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,6 +13,13 @@ if {"::tcltest" in [namespace children]} {
     namespace import -force ::tcltest::*
 }
 
+
+# The foundational objects oo::object and oo::class are sensitive to reference
+# counting errors and are deallocated only when an interp is deleted, so in
+# this test suite, interp creation and interp deletion are often used in
+# leaktests in order to leverage this sensitivity.
+
+
 testConstraint memory [llength [info commands memory]]
 if {[testConstraint memory]} {
     proc getbytes {} {
@@ -271,7 +278,21 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
     rename test-oo-1.18 {}
     A destroy
 } -result ::C
-test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
+test oo-1.18.1 {no memory leak: superclass} -setup {
+} -constraints memory -body {
+
+    leaktest {
+	interp create t
+	t eval {
+	    oo::class create A {
+		superclass oo::class
+	    }
+	}
+	interp delete t
+    }
+} -cleanup {
+} -result 0
+test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
     proc test-oo-1.18 {} return
 } -constraints memory -body {
     leaktest {
@@ -284,7 +305,7 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
 } -cleanup {
     rename test-oo-1.18 {}
 } -result 0
-test oo-1.18.2 {Bug 21c144f0f5} -setup {
+test oo-1.18.3 {Bug 21c144f0f5} -setup {
     interp create slave
 } -body {
     slave eval {
@@ -1508,7 +1529,56 @@ test oo-11.5 {OO: cleanup} {
     return done
 } done
 
-test oo-11.6 {
+test oo-11.6.1 {
+    OO: cleanup of when an class is mixed into itself
+} -constraints memory -body {
+    leaktest {
+	interp create interp1
+	oo::class create obj1
+	::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+	rename obj1 {}
+	interp delete interp1
+    }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.2 {
+    OO: cleanup ReleaseClassContents() where class is mixed into one of its
+    instances
+} -body {
+    leaktest {
+	interp create interp1
+	interp1 eval {
+	    oo::class create obj1
+	    ::oo::copy obj1 obj2
+	    rename obj2 {}
+	    rename obj1 {}
+	}
+	interp delete interp1
+    }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.3 {
+    OO: cleanup ReleaseClassContents() where class is mixed into one of its
+    instances
+} -body {
+    leaktest {
+	interp create interp1
+	interp1 eval {
+	    oo::class create obj1
+	    ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+
+	    ::oo::copy obj1 obj2
+	    rename obj2 {}
+	    rename obj1 {}
+	}
+	interp delete interp1
+    }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.4 {
     OO: cleanup ReleaseClassContents() where class is mixed into one of its
     instances
 } -body {
@@ -2071,7 +2141,18 @@ test oo-15.12 {OO: object cloning with target NS} -setup {
     Super destroy
     catch {namespace delete ::existing}
 } -result {::existing refers to an existing namespace}
-test oo-15.13 {OO: object cloning with target NS} -setup {
+test oo-15.13.1 {
+    OO: object cloning with target NS
+    Valgrind will report a leak if the reference count of the namespace isn't
+    properly incremented.
+} -setup {
+    oo::class create Cls {}
+} -body {
+    oo::copy Cls Cls2 ::dupens
+    return done
+} -cleanup {
+} -result done 
+test oo-15.13.2 {OO: object cloning with target NS} -setup {
     oo::class create Super
     oo::class create Cls {superclass Super}
 } -body {
@@ -3666,99 +3747,110 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
     cls destroy
 } -result {0 {}}
 
-oo::class create SampleSlot {
-    superclass oo::Slot
-    constructor {} {
-	variable contents {a b c} ops {}
-    }
-    method contents {} {variable contents; return $contents}
-    method ops {} {variable ops; return $ops}
-    method Get {} {
-	variable contents
-	variable ops
-	lappend ops [info level] Get
-	return $contents
-    }
-    method Set {lst} {
-	variable contents $lst
-	variable ops
-	lappend ops [info level] Set $lst
-	return
+proc SampleSlotSetup script {
+    set script0 {
+	oo::class create SampleSlot {
+	    superclass oo::Slot
+	    constructor {} {
+		variable contents {a b c} ops {}
+	    }
+	    method contents {} {variable contents; return $contents}
+	    method ops {} {variable ops; return $ops}
+	    method Get {} {
+		variable contents
+		variable ops
+		lappend ops [info level] Get
+		return $contents
+	    }
+	    method Set {lst} {
+		variable contents $lst
+		variable ops
+		lappend ops [info level] Set $lst
+		return
+	    }
+	}
+    }
+    append script0 \n$script
+}
+
+proc SampleSlotCleanup script {
+    set script0 {
+	SampleSlot destroy
     }
+    append script \n$script0
 }
 
-test oo-32.1 {TIP 380: slots - class test} -setup {
+test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
-} -body {
+}] -body {
     list [info level] [sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-} -result {0 {a b c} {}}
-test oo-32.2 {TIP 380: slots - class test} -setup {
+}] -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
-} -body {
+}] -body {
     list [info level] [sampleSlot -clear] \
 	[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-} -result {0 {} {} {1 Set {}}}
-test oo-32.3 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
-} -body {
+}] -body {
     list [info level] [sampleSlot -append g h i] \
 	[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
-test oo-32.4 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
-} -body {
+}] -body {
     list [info level] [sampleSlot -set d e f] \
 	[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-} -result {0 {} {d e f} {1 Set {d e f}}}
-test oo-32.5 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
-} -body {
+}] -body {
     list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
 	[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
 
-test oo-33.1 {TIP 380: slots - defaulting} -setup {
+test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
     set s [SampleSlot new]
-} -body {
+}] -body {
     list [$s x y] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename $s {}
-} -result {{} {a b c x y}}
-test oo-33.2 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
     set s [SampleSlot new]
-} -body {
+}] -body {
     list [$s destroy; $s unknown] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename $s {}
-} -result {{} {a b c destroy unknown}}
-test oo-33.3 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c destroy unknown}}
+test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
     set s [SampleSlot new]
-} -body {
+}] -body {
     oo::objdefine $s forward --default-operation  my -set
     list [$s destroy; $s unknown] [$s contents] [$s ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
     rename $s {}
-} -result {{} unknown {1 Set destroy 1 Set unknown}}
-test oo-33.4 {TIP 380: slots - errors} -setup {
+}] -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
     set s [SampleSlot new]
-} -body {
+}] -body {
     # Method names beginning with "-" are special to slots
     $s -grill q
-} -returnCodes error -cleanup {
+} -returnCodes error -cleanup [SampleSlotCleanup {
     rename $s {}
-} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
-
-SampleSlot destroy
+}] -result \
+    {unknown method "-grill": must be -append, -clear, -set, contents or ops}
 
 test oo-34.1 {TIP 380: slots - presence} -setup {
     set obj [oo::object new]