From 35bc1b353a52bf9deb6ca5d586f3749b1dae1f3e Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Oct 2024 19:57:26 +0000 Subject: [PATCH 1/3] Trying to fix [02977e0004], but causes other problems. --- generic/tclOO.c | 35 +++++++++++++++++++++++++---------- generic/tclOOInt.h | 4 ++++ tests/oo.test | 2 +- 3 files changed, 30 insertions(+), 11 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 27656768635..6add044e8a5 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -850,10 +850,26 @@ ObjectRenamedTrace( */ if (!Destructing(oPtr)) { - Tcl_DeleteNamespace(oPtr->namespacePtr); + ThreadLocalData *tsdPtr = GetFoundation(interp)->tsdPtr; + if (!tsdPtr->delQueueTail) { + Object *currPtr, *tmp; + tsdPtr->delQueueTail = oPtr; + for (currPtr = oPtr; currPtr; currPtr = tmp) { + Tcl_DeleteNamespace(currPtr->namespacePtr); + currPtr->command = NULL; + tmp = currPtr->delNext; + TclOODecrRefCount(currPtr); + } + tsdPtr->delQueueTail = NULL; + } else { + tsdPtr->delQueueTail->delNext = oPtr; + tsdPtr->delQueueTail = oPtr; + // Tcl_DeleteNamespace(oPtr->namespacePtr); + } + } else { + oPtr->command = NULL; + TclOODecrRefCount(oPtr); } - oPtr->command = NULL; - TclOODecrRefCount(oPtr); return; } @@ -1102,7 +1118,7 @@ ObjectNamespaceDeleted( Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - Tcl_Interp *interp = oPtr->fPtr->interp; + Tcl_Interp *interp = fPtr->interp; int i; if (Destructing(oPtr)) { @@ -1138,12 +1154,12 @@ ObjectNamespaceDeleted( if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); - int result; - Tcl_InterpState state; oPtr->flags |= DESTRUCTOR_CALLED; - if (contextPtr != NULL) { + int result; + Tcl_InterpState state; + contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; state = Tcl_SaveInterpState(interp, TCL_OK); @@ -1175,11 +1191,11 @@ ObjectNamespaceDeleted( * as well. */ - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + Tcl_DeleteCommandFromToken(interp, oPtr->command); } if (oPtr->myCommand) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); + Tcl_DeleteCommandFromToken(interp, oPtr->myCommand); } /* @@ -1254,7 +1270,6 @@ ObjectNamespaceDeleted( if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr) && !Tcl_InterpDeleted(interp)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 41c674ce85a..9ca2b15cc5b 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -197,6 +197,8 @@ typedef struct Object { /* Function to allow remapping of method * names. For itcl-ng. */ LIST_STATIC(Tcl_Obj *) variables; + struct Object *delNext; /* If non-NULL, the next object to have its + * namespace deleted. */ } Object; #define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has @@ -293,6 +295,8 @@ typedef struct ThreadLocalData { * because Tcl_Objs can cross interpreter * boundaries within a thread (objects don't * generally cross threads). */ + Object *delQueueTail; /* The tail object in the deletion queue. If + * NULL, there is no deletion queue. */ } ThreadLocalData; typedef struct Foundation { diff --git a/tests/oo.test b/tests/oo.test index 446b0f96f65..84a1003e50a 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -418,7 +418,7 @@ test oo-1.22 {basic test of OO functionality: nested ownership destruction order } -result {1 2 3 4 0} test oo-1.23 {basic test of OO functionality: deep nested ownership} -setup { oo::class create parent -} -constraints knownBug -body { +} -body { oo::class create abc { superclass parent method make {} {[self class] create xyz} From 07e79f990da33a04bef2c88c5e55fd6d1ad35a01 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 1 Nov 2024 11:49:05 +0000 Subject: [PATCH 2/3] Fix the bug by forcing classes to be destroyed eagerly while queueing instances. --- generic/tclNamesp.c | 16 +++++++--------- generic/tclOO.c | 22 ++++++++++++++++++++-- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index c76c08d5534..64551251f88 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -888,9 +888,8 @@ Tcl_DeleteNamespace( Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ { Namespace *nsPtr = (Namespace *) namespacePtr; - Interp *iPtr = (Interp *) nsPtr->interp; - Namespace *globalNsPtr = (Namespace *) - TclGetGlobalNamespace((Tcl_Interp *) iPtr); + Tcl_Interp *interp = nsPtr->interp; + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr; @@ -934,8 +933,7 @@ Tcl_DeleteNamespace( entryPtr != NULL;) { cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); if (cmdPtr->nreProc == TclNRInterpCoroutine) { - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, - (Tcl_Command) cmdPtr); + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); } else { entryPtr = Tcl_NextHashEntry(&search); @@ -958,7 +956,7 @@ Tcl_DeleteNamespace( nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; ensemblePtr->next = ensemblePtr; - Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); + Tcl_DeleteCommandFromToken(interp, ensemblePtr->token); } /* @@ -1013,7 +1011,7 @@ Tcl_DeleteNamespace( TclTeardownNamespace(nsPtr); - if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { + if ((nsPtr != globalNsPtr) || (((Interp *) interp)->flags & DELETED)) { /* * If this is the global namespace, then it may have residual * "errorInfo" and "errorCode" variables for errors that occurred @@ -1039,8 +1037,8 @@ Tcl_DeleteNamespace( * Restore the ::errorInfo and ::errorCode traces. */ - EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); - EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); + EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0); + EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0); /* * We didn't really kill it, so remove the KILLED marks, so it can diff --git a/generic/tclOO.c b/generic/tclOO.c index 6add044e8a5..8715bc8a5c7 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -850,8 +850,24 @@ ObjectRenamedTrace( */ if (!Destructing(oPtr)) { + /* + * Ensure that we don't recurse very deeply and blow out the C stack. + * [Bug 02977e0004] + */ ThreadLocalData *tsdPtr = GetFoundation(interp)->tsdPtr; - if (!tsdPtr->delQueueTail) { + if (oPtr->classPtr) { + /* + * Classes currently need the recursion to get destructor calling + * right. This is a bug, but it requires a major rewrite of things + * to fix. + */ + Tcl_DeleteNamespace(oPtr->namespacePtr); + oPtr->command = NULL; + TclOODecrRefCount(oPtr); + } else if (!tsdPtr->delQueueTail) { + /* + * Process a queue of objects to delete. + */ Object *currPtr, *tmp; tsdPtr->delQueueTail = oPtr; for (currPtr = oPtr; currPtr; currPtr = tmp) { @@ -862,9 +878,11 @@ ObjectRenamedTrace( } tsdPtr->delQueueTail = NULL; } else { + /* + * Enqueue the object. + */ tsdPtr->delQueueTail->delNext = oPtr; tsdPtr->delQueueTail = oPtr; - // Tcl_DeleteNamespace(oPtr->namespacePtr); } } else { oPtr->command = NULL; From 35fc7d6fd7bc1eaa8499da9bc8598b0f434d7021 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 1 Nov 2024 12:01:10 +0000 Subject: [PATCH 3/3] There still is a buggy case to worry about --- tests/oo.test | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 84a1003e50a..0292ddd075e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -438,6 +438,28 @@ test oo-1.23 {basic test of OO functionality: deep nested ownership} -setup { } -cleanup { parent destroy } -result 0 +test oo-1.24 {basic test of OO functionality: deep nested ownership} -setup { + oo::class create parent +} -constraints knownBug -body { + oo::class create abc { + superclass parent + self method make {} {oo::copy [self] xyz} + destructor {incr ::count} + } + apply {n { + set ::count 0 + # Make a lot of "nested" objects + set base abc + for {set i 1; set obj $base} {$i < $n} {incr i} { + set obj [$obj make] + } + # Kill them all in one go; should not crash! + $base destroy + return [expr {$n - $::count}] + }} 10000 +} -cleanup { + parent destroy +} -result 0 test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as