From 8f8f97ec13fd3def9c005b821be3f21d432f7b4a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 20 May 2024 13:38:38 +0000 Subject: Test case to demonstrate [7842f33a5c] --- tests/oo.test | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 8e2cb5f..ecd39fd 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4274,8 +4274,6 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly} } -cleanup { base destroy } -result {{c d e} {c d e}} - - test oo-35.6 { Bug : teardown of an object that is a class that is an instance of itself } -setup { @@ -4297,7 +4295,37 @@ test oo-35.6 { } -cleanup { rename obj {} } -result done - +test oo-35.7 {Bug 7842f33a5c: destructor cascading} -setup { + oo::class create base + oo::class create RpcClient { + superclass base + method write name { + lappend ::result "RpcClient -> $name" + } + method create_bug {} { + MkObjectRpc create cfg [self] 111 + } + } + oo::class create MkObjectRpc { + superclass base + variable hdl + constructor {rpcHdl mqHdl} { + set hdl $mqHdl + oo::objdefine [self] forward rpc $rpcHdl + } + destructor { + my rpc write otto-$hdl + } + } + set ::result {} +} -body { + set FH [RpcClient new] + $FH create_bug + $FH destroy + join $result \n +} -cleanup { + base destroy +} -result {} cleanupTests -- cgit v0.12 From 4f71367c38516d59d012fa0d086cf270573a191c Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 20 May 2024 15:06:52 +0000 Subject: Add some machinery for easier testing --- win/Makefile.in | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index a325ac3..1a8bd2d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -206,6 +206,7 @@ MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp +GDB = gdb CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \ -I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" -DTCL_TOMMATH \ @@ -814,7 +815,16 @@ shell: binaries # This target can be used to run tclsh inside either gdb or insight gdb: binaries @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run - gdb ./$(TCLSH) --command=gdb.run + $(GDB) ./$(TCLSH) --command=gdb.run + rm gdb.run + +shquotequote = $(subst ',\",$(subst ",\",$(1))) +gdb-test: tcltest + @printf '%s ' 'set env TCL_LIBRARY=$(LIBRARY_DIR)' > gdb.run + @printf '\n' >>gdb.run + @printf '%s ' set args $(ROOT_DIR_NATIVE)/tests/all.tcl \ + $(call shquotequote,$(TESTFLAGS)) -singleproc 1 >> gdb.run + $(GDB) ${TEST_EXE_FILE} --command=gdb.run rm gdb.run depend: -- cgit v0.12 From 596b9dd4a6c851fd4b4af614f383f90c544d6373 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 20 May 2024 15:09:01 +0000 Subject: Fix for [7842f33a5c]: Stereotype call chains were ending up bogus in some situations --- generic/tclOOCall.c | 58 +++++++++++++++++++++++++++++++++++----- tests/oo.test | 77 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 128 insertions(+), 7 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index aefd921..bfff4e9 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -891,15 +891,28 @@ InitCallChain( Object *oPtr, int flags) { + /* + * Note that it's possible to end up with a NULL oPtr->selfCls here if + * there is a call into stereotypical object after it has finished running + * its destructor phase. Such things can't be cached for a long time so the + * epoch can be bogus. [Bug 7842f33a5c] + */ + callPtr->flags = flags & (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING); if (oPtr->flags & USE_CLASS_CACHE) { - oPtr = oPtr->selfCls->thisPtr; + oPtr = (oPtr->selfCls ? oPtr->selfCls->thisPtr : NULL); callPtr->flags |= USE_CLASS_CACHE; } - callPtr->epoch = oPtr->fPtr->epoch; - callPtr->objectCreationEpoch = oPtr->creationEpoch; - callPtr->objectEpoch = oPtr->epoch; + if (oPtr) { + callPtr->epoch = oPtr->fPtr->epoch; + callPtr->objectCreationEpoch = oPtr->creationEpoch; + callPtr->objectEpoch = oPtr->epoch; + } else { + callPtr->epoch = 0; + callPtr->objectCreationEpoch = 0; + callPtr->objectEpoch = 0; + } callPtr->refCount = 1; callPtr->numChain = 0; callPtr->chain = callPtr->staticChain; @@ -930,6 +943,13 @@ IsStillValid( int mask) { if ((oPtr->flags & USE_CLASS_CACHE)) { + /* + * If the object is in a weird state (due to stereotype tricks) then + * just declare the cache invalid. [Bug 7842f33a5c] + */ + if (!oPtr->selfCls) { + return 0; + } oPtr = oPtr->selfCls->thisPtr; flags |= USE_CLASS_CACHE; } @@ -1020,8 +1040,16 @@ TclOOGetCallContext( FreeMethodNameRep(cacheInThisObj); } - if (oPtr->flags & USE_CLASS_CACHE) { - if (oPtr->selfCls->classChainCache != NULL) { + /* + * Note that it's possible to end up with a NULL oPtr->selfCls here if + * there is a call into stereotypical object after it has finished + * running its destructor phase. It's quite a tangle, but at that + * point, we simply can't get stereotypes from the cache. + * [Bug 7842f33a5c] + */ + + if (oPtr->flags & USE_CLASS_CACHE && oPtr->selfCls) { + if (oPtr->selfCls->classChainCache) { hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache, (char *) methodNameObj); } else { @@ -1226,6 +1254,17 @@ TclOOGetStereotypeCallChain( Object obj; /* + * Note that it's possible to end up with a NULL clsPtr here if there is + * a call into stereotypical object after it has finished running its + * destructor phase. It's quite a tangle, but at that point, we simply + * can't get stereotypes. [Bug 7842f33a5c] + */ + + if (clsPtr == NULL) { + return NULL; + } + + /* * Synthesize a temporary stereotypical object so that we can use existing * machinery to produce the stereotypical call chain. */ @@ -1448,9 +1487,16 @@ AddSimpleClassChainToCallContext( * * Note that mixins must be processed before the main class hierarchy. * [Bug 1998221] + * + * Note also that it's possible to end up with a null classPtr here if + * there is a call into stereotypical object after it has finished running + * its destructor phase. [Bug 7842f33a5c] */ tailRecurse: + if (classPtr == NULL) { + return; + } FOREACH(superPtr, classPtr->mixins) { AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, filterDecl); diff --git a/tests/oo.test b/tests/oo.test index ecd39fd..366f4d3 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4295,7 +4295,7 @@ test oo-35.6 { } -cleanup { rename obj {} } -result done -test oo-35.7 {Bug 7842f33a5c: destructor cascading} -setup { +test oo-35.7.1 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { oo::class create base oo::class create RpcClient { superclass base @@ -4326,6 +4326,81 @@ test oo-35.7 {Bug 7842f33a5c: destructor cascading} -setup { } -cleanup { base destroy } -result {} +test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { + oo::class create base + oo::class create RpcClient { + superclass base + method write name { + lappend ::result "RpcClient -> $name" + } + method create_bug {} { + MkObjectRpc create cfg [self] 111 + } + destructor { + lappend ::result "Destroyed" + } + } + oo::class create MkObjectRpc { + superclass base + variable hdl + constructor {rpcHdl mqHdl} { + set hdl $mqHdl + oo::objdefine [self] forward rpc $rpcHdl + } + destructor { + my rpc write otto-$hdl + } + } + set ::result {} +} -body { + set FH [RpcClient new] + $FH create_bug + $FH destroy + join $result \n +} -cleanup { + base destroy +} -result {Destroyed} +test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { + oo::class create base + oo::class create RpcClient { + superclass base + variable interiorObjects + method write name { + lappend ::result "RpcClient -> $name" + } + method create_bug {} { + set obj [MkObjectRpc create cfg [self] 111] + lappend interiorObjects $obj + return $obj + } + destructor { + lappend ::result "Destroyed" + # Explicit destroy of interior objects + foreach obj $interiorObjects { + $obj destroy + } + } + } + oo::class create MkObjectRpc { + superclass base + variable hdl + constructor {rpcHdl mqHdl} { + set hdl $mqHdl + oo::objdefine [self] forward rpc $rpcHdl + } + destructor { + my rpc write otto-$hdl + } + } + set ::result {} +} -body { + set FH [RpcClient new] + $FH create_bug + $FH destroy + join $result \n +} -cleanup { + base destroy +} -result "Destroyed\nRpcClient -> otto-111" cleanupTests -- cgit v0.12