From aa585c0ac925c9ca50a5a98d65e576eb93e5afcc Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 17 May 2024 11:11:31 +0000 Subject: Starting to clean up the mess. The extra frame info can have the same lifespan as the method itself. --- generic/tclOOInt.h | 9 ++++ generic/tclOOMethod.c | 136 ++++++++++++++++++++++++++++++-------------------- tests/oo.test | 49 ++++++++++-------- 3 files changed, 120 insertions(+), 74 deletions(-) diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 2931044..e7d727a 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -97,6 +97,15 @@ typedef struct ProcedureMethod { GetFrameInfoValueProc *gfivProc; /* Callback to allow for fine tuning of how * the method reports itself. */ + ExtraFrameInfo efi; /* Space used to store data for [info frame] */ + Tcl_Interp *interp; /* Interpreter in which to compute the name of + * the method. */ + Tcl_Method method; /* Method to compute the name of. */ + int callSiteFlags; /* Flags from the call chain. Only interested + * in whether this is a constructor or + * destructor, which we can't know until then + * for messy reasons. Other flags are variable + * but not used. */ } ProcedureMethod; #define TCLOO_PROCEDURE_METHOD_VERSION 0 diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index edaa593..1347aa5 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -17,17 +17,6 @@ #include "tclCompile.h" /* - * Structure used to help delay computing names of objects or classes for - * [info frame] until needed, making invocation faster in the normal case. - */ - -struct PNI { - Tcl_Interp *interp; /* Interpreter in which to compute the name of - * a method. */ - Tcl_Method method; /* Method to compute the name of. */ -}; - -/* * Structure used to contain all the information needed about a call frame * used in a procedure-like method. */ @@ -38,11 +27,8 @@ typedef struct { ProcErrorProc *errProc; /* The error handler for the body. */ Tcl_Obj *nameObj; /* The "name" of the command. */ Command cmd; /* The command structure. Mostly bogus. */ - ExtraFrameInfo efi; /* Extra information used for [info frame]. */ Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a * recursive call returns. */ - struct PNI pni; /* Specialist information used in the efi - * field for this type of call. */ } PMFrameData; /* @@ -86,6 +72,9 @@ static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); +static inline void InitFrameInfo(Tcl_Interp *interp, + ProcedureMethod *pmPtr, Tcl_ObjectContext context); +static Tcl_Obj * RenderMethodName(void *clientData); static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, @@ -658,7 +647,7 @@ TclOOMakeProcMethod( static int InvokeProcedureMethod( - void *clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ @@ -682,6 +671,8 @@ InvokeProcedureMethod( Tcl_ObjectContextSkippedArgs(context)); } + InitFrameInfo(interp, pmPtr, context); + /* * Allocate the special frame data. */ @@ -737,6 +728,48 @@ InvokeProcedureMethod( Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc); } +/* + * Finishes filling out the extra frame info so that [info frame] works. + */ +static inline void +InitFrameInfo( + Tcl_Interp *interp, /* For object name resolution later. */ + ProcedureMethod *pmPtr, /* What we're writing to. */ + Tcl_ObjectContext context) /* The calling context, used to figure out how + * we're using the method. */ +{ + Tcl_Method method = Tcl_ObjectContextMethod(context); + + if (pmPtr->efi.length) { + /* + * Do nothing if already set up. + */ + return; + } + + pmPtr->efi.length = 2; + pmPtr->efi.fields[0].name = "method"; + pmPtr->efi.fields[0].proc = RenderMethodName; + pmPtr->efi.fields[0].clientData = pmPtr; + pmPtr->callSiteFlags = ((CallContext *) + context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); + pmPtr->interp = interp; + pmPtr->method = method; + if (pmPtr->gfivProc != NULL) { + pmPtr->efi.fields[1].name = ""; + pmPtr->efi.fields[1].proc = pmPtr->gfivProc; + pmPtr->efi.fields[1].clientData = pmPtr; + } else { + if (Tcl_MethodDeclarerObject(method) != NULL) { + pmPtr->efi.fields[1].name = "object"; + } else { + pmPtr->efi.fields[1].name = "class"; + } + pmPtr->efi.fields[1].proc = RenderDeclarerName; + pmPtr->efi.fields[1].clientData = pmPtr; + } +} + static int FinalizePMCall( void *data[], @@ -791,7 +824,6 @@ PushMethodCallFrame( { Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; int result; - const char *namePtr; CallFrame **framePtrPtr = &fdPtr->framePtr; /* @@ -799,17 +831,14 @@ PushMethodCallFrame( */ if (contextPtr->callPtr->flags & CONSTRUCTOR) { - namePtr = ""; fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName; fdPtr->errProc = ConstructorErrorHandler; } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - namePtr = ""; fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName; fdPtr->errProc = DestructorErrorHandler; } else { fdPtr->nameObj = Tcl_MethodName( Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr)); - namePtr = TclGetString(fdPtr->nameObj); fdPtr->errProc = MethodErrorHandler; } if (pmPtr->errProc != NULL) { @@ -822,8 +851,7 @@ PushMethodCallFrame( */ if (pmPtr->flags & USE_DECLARER_NS) { - Method *mPtr = - contextPtr->callPtr->chain[contextPtr->index].mPtr; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; if (mPtr->declaringClassPtr != NULL) { nsPtr = (Namespace *) @@ -845,10 +873,9 @@ PushMethodCallFrame( * Compile the body. This operation may fail. */ - fdPtr->efi.length = 2; memset(&fdPtr->cmd, 0, sizeof(Command)); fdPtr->cmd.nsPtr = nsPtr; - fdPtr->cmd.clientData = &fdPtr->efi; + fdPtr->cmd.clientData = &pmPtr->efi; pmPtr->procPtr->cmdPtr = &fdPtr->cmd; /* @@ -865,7 +892,8 @@ PushMethodCallFrame( codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, - pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); + pmPtr->procPtr->bodyPtr, nsPtr, "body of method", + TclGetString(fdPtr->nameObj)); if (result != TCL_OK) { goto failureReturn; } @@ -883,32 +911,6 @@ PushMethodCallFrame( fdPtr->framePtr->objv = objv; fdPtr->framePtr->procPtr = pmPtr->procPtr; - /* - * Finish filling out the extra frame info so that [info frame] works. - */ - - fdPtr->efi.fields[0].name = "method"; - fdPtr->efi.fields[0].proc = NULL; - fdPtr->efi.fields[0].clientData = fdPtr->nameObj; - if (pmPtr->gfivProc != NULL) { - fdPtr->efi.fields[1].name = ""; - fdPtr->efi.fields[1].proc = pmPtr->gfivProc; - fdPtr->efi.fields[1].clientData = pmPtr; - } else { - Tcl_Method method = - Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr); - - if (Tcl_MethodDeclarerObject(method) != NULL) { - fdPtr->efi.fields[1].name = "object"; - } else { - fdPtr->efi.fields[1].name = "class"; - } - fdPtr->efi.fields[1].proc = RenderDeclarerName; - fdPtr->efi.fields[1].clientData = &fdPtr->pni; - fdPtr->pni.interp = interp; - fdPtr->pni.method = method; - } - return TCL_OK; /* @@ -1115,6 +1117,32 @@ ProcedureMethodCompiledVarResolver( /* * ---------------------------------------------------------------------- * + * RenderMethodName -- + * + * Returns the name of the declared method. Used for producing information + * for [info frame]. + * + * ---------------------------------------------------------------------- + */ + +static Tcl_Obj * +RenderMethodName( + void *clientData) +{ + ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; + + if (pmPtr->callSiteFlags & CONSTRUCTOR) { + return TclOOGetFoundation(pmPtr->interp)->constructorName; + } else if (pmPtr->callSiteFlags & DESTRUCTOR) { + return TclOOGetFoundation(pmPtr->interp)->destructorName; + } else { + return Tcl_MethodName(pmPtr->method); + } +} + +/* + * ---------------------------------------------------------------------- + * * RenderDeclarerName -- * * Returns the name of the entity (object or class) which declared a @@ -1129,13 +1157,13 @@ static Tcl_Obj * RenderDeclarerName( void *clientData) { - struct PNI *pni = (struct PNI *)clientData; - Tcl_Object object = Tcl_MethodDeclarerObject(pni->method); + ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; + Tcl_Object object = Tcl_MethodDeclarerObject(pmPtr->method); if (object == NULL) { - object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method)); + object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pmPtr->method)); } - return TclOOObjectName(pni->interp, (Object *) object); + return TclOOObjectName(pmPtr->interp, (Object *) object); } /* diff --git a/tests/oo.test b/tests/oo.test index 7266255..8bc6363 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3296,40 +3296,49 @@ test oo-22.2 {OO and info frame: Bug 3001438} -setup { } -match glob -cleanup { c destroy } -result {* cmd {info frame 0} method test class ::c level 0} -# BUG: second call is missing info (caused by workaround in tclCmdIL.c) test oo-22.3 {OO and coroutines and info frame} -constraints knownBug -setup { oo::class create A { - self method run {nworkers} { - set ::result {} - set workers {} - for {set n 1} {$n <= $nworkers} {incr n} { - set worker [A create a$n] - lappend workers $worker - $worker schedule + self { + variable result stop + method WithWorkers {nworkers args script} { + set workers {} + try { + for {set n 1} {$n <= $nworkers} {incr n} { + lappend workers [set worker [[self] new]] + $worker schedule {*}$args + } + return [uplevel 1 $script] + } finally { + foreach worker $workers {$worker destroy} + } } - after 250 [namespace code {variable forever false}] - variable forever true - vwait [my varname forever] - foreach worker $workers { - $worker destroy + method run {nworkers} { + set result {} + set stopvar [my varname stop] + set stop false + my WithWorkers $nworkers [list my Work [my varname result]] { + after idle [namespace code {set stop true}] + vwait $stopvar + } + return $result } - return $::result } - method schedule {} { - set coro coro-[namespace tail [self]] - if {[llength [info commands $coro]] == 0} { - coroutine $coro my Work + method schedule {args} { + set coro [namespace current]::coro + if {![llength [info commands $coro]]} { + coroutine $coro {*}$args } } - method Work {} { + method Work {var} { after 0 [info coroutine] yield - lappend ::result [dump] + lappend $var [dump] } } } -body { # Triggers a crash with incorrectly restored procPtr->cmdPtr proc dump {} { + # Called from [A Work] after a coroutine suspend/resume info frame [expr {[info frame] - 1}] } A run 2 -- cgit v0.12 From 3c40e6048981fffbf3f87e3097fd7b14b748e79b Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 17 May 2024 13:28:51 +0000 Subject: Fix the problem properly --- generic/tclOOInt.h | 1 + generic/tclOOMethod.c | 158 ++++++++++++++++++-------------------------------- tests/oo.test | 137 +++++++++++++++++++++++++++++++------------ 3 files changed, 157 insertions(+), 139 deletions(-) diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index e7d727a..41c674c 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -97,6 +97,7 @@ typedef struct ProcedureMethod { GetFrameInfoValueProc *gfivProc; /* Callback to allow for fine tuning of how * the method reports itself. */ + Command cmd; /* Space used to connect to [info frame] */ ExtraFrameInfo efi; /* Space used to store data for [info frame] */ Tcl_Interp *interp; /* Interpreter in which to compute the name of * the method. */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 1347aa5..5cff201 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -25,10 +25,8 @@ typedef struct { CallFrame *framePtr; /* Reference to the call frame itself (it's * actually allocated on the Tcl stack). */ ProcErrorProc *errProc; /* The error handler for the body. */ - Tcl_Obj *nameObj; /* The "name" of the command. */ - Command cmd; /* The command structure. Mostly bogus. */ - Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a - * recursive call returns. */ + Tcl_Obj *nameObj; /* The "name" of the command. Only used for a + * few moments, so not reference. */ } PMFrameData; /* @@ -72,8 +70,6 @@ static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); -static inline void InitFrameInfo(Tcl_Interp *interp, - ProcedureMethod *pmPtr, Tcl_ObjectContext context); static Tcl_Obj * RenderMethodName(void *clientData); static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, @@ -111,6 +107,20 @@ static const Tcl_MethodType fwdMethodType = { ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry))) + +static inline ProcedureMethod * +AllocProcedureMethodRecord( + int flags) +{ + ProcedureMethod *pmPtr = (ProcedureMethod *) + ckalloc(sizeof(ProcedureMethod)); + memset(pmPtr, 0, sizeof(ProcedureMethod)); + pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; + pmPtr->flags = flags & USE_DECLARER_NS; + pmPtr->refCount = 1; + pmPtr->cmd.clientData = &pmPtr->efi; + return pmPtr; +} /* * ---------------------------------------------------------------------- @@ -331,12 +341,7 @@ TclOONewProcInstanceMethod( if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); - memset(pmPtr, 0, sizeof(ProcedureMethod)); - pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; - pmPtr->flags = flags & USE_DECLARER_NS; - pmPtr->refCount = 1; - + pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { @@ -392,12 +397,7 @@ TclOONewProcMethod( procName = (nameObj==NULL ? "" : TclGetString(nameObj)); } - pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); - memset(pmPtr, 0, sizeof(ProcedureMethod)); - pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; - pmPtr->flags = flags & USE_DECLARER_NS; - pmPtr->refCount = 1; - + pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); @@ -671,7 +671,36 @@ InvokeProcedureMethod( Tcl_ObjectContextSkippedArgs(context)); } - InitFrameInfo(interp, pmPtr, context); + /* + * Finishes filling out the extra frame info so that [info frame] works if + * that is not already set up. + */ + + if (pmPtr->efi.length == 0) { + Tcl_Method method = Tcl_ObjectContextMethod(context); + + pmPtr->efi.length = 2; + pmPtr->efi.fields[0].name = "method"; + pmPtr->efi.fields[0].proc = RenderMethodName; + pmPtr->efi.fields[0].clientData = pmPtr; + pmPtr->callSiteFlags = ((CallContext *) + context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); + pmPtr->interp = interp; + pmPtr->method = method; + if (pmPtr->gfivProc != NULL) { + pmPtr->efi.fields[1].name = ""; + pmPtr->efi.fields[1].proc = pmPtr->gfivProc; + pmPtr->efi.fields[1].clientData = pmPtr; + } else { + if (Tcl_MethodDeclarerObject(method) != NULL) { + pmPtr->efi.fields[1].name = "object"; + } else { + pmPtr->efi.fields[1].name = "class"; + } + pmPtr->efi.fields[1].proc = RenderDeclarerName; + pmPtr->efi.fields[1].clientData = pmPtr; + } + } /* * Allocate the special frame data. @@ -702,13 +731,6 @@ InvokeProcedureMethod( result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { - /* - * Restore the old cmdPtr so that a subsequent use of [info frame] - * won't crash on us. [Bug 3001438] - */ - - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); if (pmPtr->refCount-- <= 1) { @@ -728,48 +750,6 @@ InvokeProcedureMethod( Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc); } -/* - * Finishes filling out the extra frame info so that [info frame] works. - */ -static inline void -InitFrameInfo( - Tcl_Interp *interp, /* For object name resolution later. */ - ProcedureMethod *pmPtr, /* What we're writing to. */ - Tcl_ObjectContext context) /* The calling context, used to figure out how - * we're using the method. */ -{ - Tcl_Method method = Tcl_ObjectContextMethod(context); - - if (pmPtr->efi.length) { - /* - * Do nothing if already set up. - */ - return; - } - - pmPtr->efi.length = 2; - pmPtr->efi.fields[0].name = "method"; - pmPtr->efi.fields[0].proc = RenderMethodName; - pmPtr->efi.fields[0].clientData = pmPtr; - pmPtr->callSiteFlags = ((CallContext *) - context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); - pmPtr->interp = interp; - pmPtr->method = method; - if (pmPtr->gfivProc != NULL) { - pmPtr->efi.fields[1].name = ""; - pmPtr->efi.fields[1].proc = pmPtr->gfivProc; - pmPtr->efi.fields[1].clientData = pmPtr; - } else { - if (Tcl_MethodDeclarerObject(method) != NULL) { - pmPtr->efi.fields[1].name = "object"; - } else { - pmPtr->efi.fields[1].name = "class"; - } - pmPtr->efi.fields[1].proc = RenderDeclarerName; - pmPtr->efi.fields[1].clientData = pmPtr; - } -} - static int FinalizePMCall( void *data[], @@ -792,13 +772,6 @@ FinalizePMCall( } /* - * Restore the old cmdPtr so that a subsequent use of [info frame] won't - * crash on us. [Bug 3001438] - */ - - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - - /* * Scrap the special frame data now that we're done with it. Note that we * are inlining DeleteProcedureMethod() here; this location is highly * sensitive when it comes to performance! @@ -862,29 +835,15 @@ PushMethodCallFrame( } /* - * Save the old cmdPtr so that when this recursive call returns, we can - * restore it. To do otherwise causes crashes in [info frame] after we - * return from a recursive call. [Bug 3001438] - */ - - fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr; - - /* - * Compile the body. This operation may fail. - */ - - memset(&fdPtr->cmd, 0, sizeof(Command)); - fdPtr->cmd.nsPtr = nsPtr; - fdPtr->cmd.clientData = &pmPtr->efi; - pmPtr->procPtr->cmdPtr = &fdPtr->cmd; - - /* + * Compile the body. + * * [Bug 2037727] Always call TclProcCompileProc so that we check not only * that we have bytecode, but also that it remains valid. Note that we set * the namespace of the code here directly; this is a hack, but the * alternative is *so* slow... */ + pmPtr->procPtr->cmdPtr = &pmPtr->cmd; if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; @@ -895,12 +854,12 @@ PushMethodCallFrame( pmPtr->procPtr->bodyPtr, nsPtr, "body of method", TclGetString(fdPtr->nameObj)); if (result != TCL_OK) { - goto failureReturn; + return result; } /* * Make the stack frame and fill it out with information about this call. - * This operation may fail. + * This operation doesn't ever actually fail. */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, @@ -912,15 +871,6 @@ PushMethodCallFrame( fdPtr->framePtr->procPtr = pmPtr->procPtr; return TCL_OK; - - /* - * Restore the old cmdPtr so that a subsequent use of [info frame] won't - * crash on us. [Bug 3001438] - */ - - failureReturn: - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - return result; } /* @@ -1357,6 +1307,8 @@ CloneProcedureMethod( pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; + pm2Ptr->cmd.clientData = &pm2Ptr->efi; + pm2Ptr->efi.length = 0; /* Trigger a reinit of this. */ Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, diff --git a/tests/oo.test b/tests/oo.test index 8bc6363..8e2cb5f 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3296,56 +3296,121 @@ test oo-22.2 {OO and info frame: Bug 3001438} -setup { } -match glob -cleanup { c destroy } -result {* cmd {info frame 0} method test class ::c level 0} -test oo-22.3 {OO and coroutines and info frame} -constraints knownBug -setup { - oo::class create A { - self { - variable result stop - method WithWorkers {nworkers args script} { - set workers {} - try { - for {set n 1} {$n <= $nworkers} {incr n} { - lappend workers [set worker [[self] new]] - $worker schedule {*}$args - } - return [uplevel 1 $script] - } finally { - foreach worker $workers {$worker destroy} - } - } - method run {nworkers} { - set result {} - set stopvar [my varname stop] - set stop false - my WithWorkers $nworkers [list my Work [my varname result]] { - after idle [namespace code {set stop true}] - vwait $stopvar - } - return $result +# Common code for oo-22.{3,4,5,6} +oo::class create WorkerBase +oo::class create WorkerSupport { + superclass oo::class WorkerBase + variable result stop + method WithWorkers {nworkers args script} { + set workers {} + try { + for {set n 1} {$n <= $nworkers} {incr n} { + lappend workers [set worker [[self] new]] + $worker schedule {*}$args } + return [uplevel 1 $script] + } finally { + foreach worker $workers {$worker destroy} + } + } + method run {nworkers} { + set result {} + set stopvar [my varname stop] + set stop false + my WithWorkers $nworkers [list my Work [my varname result]] { + after idle [namespace code {set stop true}] + vwait $stopvar } - method schedule {args} { - set coro [namespace current]::coro - if {![llength [info commands $coro]]} { - coroutine $coro {*}$args - } + return $result + } +} +oo::class create Worker { + superclass WorkerBase + method schedule {args} { + set coro [namespace current]::coro + if {![llength [info commands $coro]]} { + coroutine $coro {*}$args } + } + method Work args {error unimplemented} + method dump {} { + info frame [expr {[info frame] - 1}] + } +} +test oo-22.3 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly restored pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker method Work {var} { after 0 [info coroutine] yield - lappend $var [dump] + lappend $var [my dump] } } -} -body { - # Triggers a crash with incorrectly restored procPtr->cmdPtr - proc dump {} { - # Called from [A Work] after a coroutine suspend/resume - info frame [expr {[info frame] - 1}] + A run 2 +} -cleanup { + catch {rename dump {}} + catch {A destroy} +} -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} +test oo-22.4 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker + method Work {var} { + after 0 [info coroutine] + yield + lappend $var [my dump] + } + } + # Copies the methods, changing the declarer + # Test it works with the source class still around + oo::copy A B + B run 2 +} -cleanup { + catch {rename dump {}} + catch {A destroy} + catch {B destroy} +} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} +test oo-22.5 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker + method Work {var} { + after 0 [info coroutine] + yield + lappend $var [my dump] + } + } + # Copies the methods, changing the declarer + # Test it works with the source class deleted + oo::copy A B + catch {A destroy} + B run 2 +} -cleanup { + catch {rename dump {}} + catch {B destroy} +} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} +test oo-22.6 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker + method Work {var} { + after 0 [info coroutine] + yield + lappend $var [my dump] + } } + # Copies the methods, changing the declarer + # Test it works in the original source class with the copy around + oo::copy A B + B run 2 A run 2 } -cleanup { catch {rename dump {}} catch {A destroy} + catch {B destroy} } -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} +WorkerBase destroy # Prove that the issue in [Bug 1865054] isn't an issue any more test oo-23.1 {Self-like derivation; complex case!} -setup { -- cgit v0.12 From 676259e74c9990ba84fe48d0234fd422034f14f7 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 17 May 2024 13:29:12 +0000 Subject: Remove the band-aid --- generic/tclCmdIL.c | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 279bc7b..aef0399 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1388,12 +1388,7 @@ TclInfoFrame( * Procedure CallFrame. */ - if (procPtr != NULL -#ifndef AVOID_EMERGENCY_HACKS - /* Emergency band-aid fix for [87271f7cd6] */ - && procPtr->cmdPtr != NULL -#endif - ) { + if (procPtr != NULL) { Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; if (namePtr) { -- cgit v0.12