Fix for [f97d4ee020]; use a two-stage approach to avoid quadratic behavior.

3 files changed, 113 insertions, 31 deletions

diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index dfab185..58a86d9 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1105,8 +1105,6 @@ TclTeardownNamespace(
     Interp *iPtr = (Interp *) nsPtr->interp;
     register Tcl_HashEntry *entryPtr;
     Tcl_HashSearch search;
-    Tcl_Namespace *childNsPtr;
-    Tcl_Command cmd;
     int i;
 
     /*
@@ -1121,16 +1119,31 @@ TclTeardownNamespace(
     /*
      * Delete all commands in this namespace. Be careful when traversing the
      * hash table: when each command is deleted, it removes itself from the
-     * command table.
-     *
-     * Don't optimize to Tcl_NextHashEntry() because of traces.
+     * command table. Because of traces (and the desire to avoid the quadratic
+     * problems of just using Tcl_FirstHashEntry over and over, [Bug
+     * f97d4ee020]) we copy to a temporary array and then delete all those
+     * commands.
      */
 
-    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
-	    entryPtr != NULL;
-	    entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
-	cmd = Tcl_GetHashValue(entryPtr);
-	Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
+    while (nsPtr->cmdTable.numEntries > 0) {
+	int length = nsPtr->cmdTable.numEntries;
+	Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr,
+		sizeof(Command *) * length);
+
+	i = 0;
+	for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+		entryPtr != NULL;
+		entryPtr = Tcl_NextHashEntry(&search)) {
+	    cmds[i] = Tcl_GetHashValue(entryPtr);
+	    cmds[i]->refCount++;
+	    i++;
+	}
+	for (i = 0 ; i < length ; i++) {
+	    Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
+		    (Tcl_Command) cmds[i]);
+	    TclCleanupCommandMacro(cmds[i]);
+	}
+	TclStackFree((Tcl_Interp *) iPtr, cmds);
     }
     Tcl_DeleteHashTable(&nsPtr->cmdTable);
     Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
@@ -1175,25 +1188,54 @@ TclTeardownNamespace(
      *
      * BE CAREFUL: When each child is deleted, it will divorce itself from its
      * parent. You can't traverse a hash table properly if its elements are
-     * being deleted. We use only the Tcl_FirstHashEntry function to be safe.
+     * being deleted.  Because of traces (and the desire to avoid the
+     * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
+     * f97d4ee020]) we copy to a temporary array and then delete all those
+     * namespaces.
      *
-     * Don't optimize to Tcl_NextHashEntry() because of traces.
+     * Important: leave the hash table itself still live.
      */
 
 #ifndef BREAK_NAMESPACE_COMPAT
-    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
-	    entryPtr != NULL;
-	    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
-	childNsPtr = Tcl_GetHashValue(entryPtr);
-	Tcl_DeleteNamespace(childNsPtr);
+    while (nsPtr->childTable.numEntries > 0) {
+	int length = nsPtr->childTable.numEntries;
+	Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
+		sizeof(Namespace *) * length);
+
+	i = 0;
+	for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+		entryPtr != NULL;
+		entryPtr = Tcl_NextHashEntry(&search)) {
+	    children[i] = Tcl_GetHashValue(entryPtr);
+	    children[i]->refCount++;
+	    i++;
+	}
+	for (i = 0 ; i < length ; i++) {
+	    Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+	    TclNsDecrRefCount(children[i]);
+	}
+	TclStackFree((Tcl_Interp *) iPtr, children);
     }
 #else
     if (nsPtr->childTablePtr != NULL) {
-	for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
-		entryPtr != NULL;
-		entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr,&search)) {
-	    childNsPtr = Tcl_GetHashValue(entryPtr);
-	    Tcl_DeleteNamespace(childNsPtr);
+	while (nsPtr->childTablePtr->numEntries > 0) {
+	    int length = nsPtr->childTablePtr->numEntries;
+	    Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
+		    sizeof(Namespace *) * length);
+
+	    i = 0;
+	    for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+		    entryPtr != NULL;
+		    entryPtr = Tcl_NextHashEntry(&search)) {
+		children[i] = Tcl_GetHashValue(entryPtr);
+		children[i]->refCount++;
+		i++;
+	    }
+	    for (i = 0 ; i < length ; i++) {
+		Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+		TclNsDecrRefCount(children[i]);
+	    }
+	    TclStackFree((Tcl_Interp *) iPtr, children);
 	}
     }
 #endif
diff --git a/tests/assemble.test b/tests/assemble.test
index 9813545..d17bfd9 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -3281,7 +3281,9 @@ test assemble-51.4 {memory leak testing} memory {
 } 0
 
 test assemble-52.1 {Bug 3154ea2759} {
-    proc __BEGIN {} {
+    apply {{} {
+	# Needs six exception ranges to force the range allocations to use the
+	# malloced store.
 	::tcl::unsupported::assemble {
 	    beginCatch @badLabel
 	    push error
@@ -3291,7 +3293,7 @@ test assemble-52.1 {Bug 3154ea2759} {
 	    push 0
 	    jump @okLabel
 	    label @badLabel
-	    push 1; # should be pushReturnCode
+	    push 1;		# should be pushReturnCode
 	    label @okLabel
 	    endCatch
 	    pop
@@ -3304,7 +3306,7 @@ test assemble-52.1 {Bug 3154ea2759} {
 	    push 0
 	    jump @okLabel2
 	    label @badLabel2
-	    push 1; # should be pushReturnCode
+	    push 1;		# should be pushReturnCode
 	    label @okLabel2
 	    endCatch
 	    pop
@@ -3317,7 +3319,7 @@ test assemble-52.1 {Bug 3154ea2759} {
 	    push 0
 	    jump @okLabel3
 	    label @badLabel3
-	    push 1; # should be pushReturnCode
+	    push 1;		# should be pushReturnCode
 	    label @okLabel3
 	    endCatch
 	    pop
@@ -3330,7 +3332,7 @@ test assemble-52.1 {Bug 3154ea2759} {
 	    push 0
 	    jump @okLabel4
 	    label @badLabel4
-	    push 1; # should be pushReturnCode
+	    push 1;		# should be pushReturnCode
 	    label @okLabel4
 	    endCatch
 	    pop
@@ -3343,7 +3345,7 @@ test assemble-52.1 {Bug 3154ea2759} {
 	    push 0
 	    jump @okLabel5
 	    label @badLabel5
-	    push 1; # should be pushReturnCode
+	    push 1;		# should be pushReturnCode
 	    label @okLabel5
 	    endCatch
 	    pop
@@ -3356,13 +3358,12 @@ test assemble-52.1 {Bug 3154ea2759} {
 	    push 0
 	    jump @okLabel6
 	    label @badLabel6
-	    push 1; # should be pushReturnCode
+	    push 1;		# should be pushReturnCode
 	    label @okLabel6
 	    endCatch
 	    pop
 	}
-    }
-    __BEGIN
+    }}
 } {};				# must not crash
 
 rename fillTables {}
diff --git a/tests/namespace.test b/tests/namespace.test
index 47c8001..5c5783b 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -2953,6 +2953,45 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \
 test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
     info class [format %s constructor] oo::object
 } ""
+
+test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
+    namespace eval ::testing {
+	proc abc {} {}
+	proc def {} {}
+	trace add command abc delete "rename ::testing::def {}; #"
+	trace add command def delete "rename ::testing::abc {}; #"
+    }
+    namespace delete ::testing
+} {}
+test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} {
+    namespace eval ::testing {
+	namespace eval abc {proc xyz {} {}}
+	namespace eval def {proc xyz {} {}}
+	trace add command abc::xyz delete "namespace delete ::testing::def {}; #"
+	trace add command def::xyz delete "namespace delete ::testing::abc {}; #"
+    }
+    namespace delete ::testing
+} {}
+test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} {
+    namespace eval ::testing {
+	variable gone {}
+	oo::class create CB {
+	    variable cmd
+	    constructor other {set cmd $other}
+	    destructor {rename $cmd {}; lappend ::testing::gone $cmd}
+	}
+	namespace eval abc {
+	    ::testing::CB create def ::testing::abc::ghi
+	    ::testing::CB create ghi ::testing::abc::def
+	}
+	namespace delete abc
+	try {
+	    return [lsort $gone]
+	} finally {
+	    namespace delete ::testing
+	}
+    }
+} {::testing::abc::def ::testing::abc::ghi}
 
 # cleanup
 catch {rename cmd1 {}}