Proper fix for [87271f7cd6]. Structures relating to [info frame] in a method now have the correct lifetime.

4 files changed, 203 insertions, 144 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 13f16b6..37c9822 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1382,12 +1382,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) {
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 031b910..5700b16 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -97,6 +97,16 @@ 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. */
+    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 be51f0b..2e40d5b 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.
  */
@@ -36,13 +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. */
-    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. */
+    Tcl_Obj *nameObj;		/* The "name" of the command. Only used for a
+				 * few moments, so not reference. */
 } PMFrameData;
 
 /*
@@ -83,6 +67,7 @@ static int		CloneProcedureMethod(Tcl_Interp *interp,
 static ProcErrorProc	MethodErrorHandler;
 static ProcErrorProc	ConstructorErrorHandler;
 static ProcErrorProc	DestructorErrorHandler;
+static Tcl_Obj *	RenderMethodName(void *clientData);
 static Tcl_Obj *	RenderDeclarerName(void *clientData);
 static int		InvokeForwardMethod(void *clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
@@ -114,6 +99,20 @@ static const Tcl_MethodType fwdMethodType = {
     ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
 #define TclVarHashGetValue(hPtr) \
     ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
+
+static inline ProcedureMethod *
+AllocProcedureMethodRecord(
+    int flags)
+{
+    ProcedureMethod *pmPtr = (ProcedureMethod *)
+	    Tcl_Alloc(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;
+}
 
 /*
  * ----------------------------------------------------------------------
@@ -428,12 +427,7 @@ TclOONewProcInstanceMethod(
     if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
 	return NULL;
     }
-    pmPtr = (ProcedureMethod *)Tcl_Alloc(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) {
@@ -489,12 +483,7 @@ TclOONewProcMethod(
 	procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
     }
 
-    pmPtr = (ProcedureMethod *)Tcl_Alloc(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);
 
@@ -744,7 +733,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. */
@@ -768,6 +757,37 @@ InvokeProcedureMethod(
     }
 
     /*
+     * 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.
      */
 
@@ -796,13 +816,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) {
@@ -844,13 +857,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!
@@ -876,7 +882,6 @@ PushMethodCallFrame(
 {
     Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
     int result;
-    const char *namePtr;
     CallFrame **framePtrPtr = &fdPtr->framePtr;
     ByteCode *codePtr;
 
@@ -885,17 +890,14 @@ PushMethodCallFrame(
      */
 
     if (contextPtr->callPtr->flags & CONSTRUCTOR) {
-	namePtr = "<constructor>";
 	fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName;
 	fdPtr->errProc = ConstructorErrorHandler;
     } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
-	namePtr = "<destructor>";
 	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) {
@@ -908,8 +910,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 *)
@@ -920,43 +921,29 @@ 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.
-     */
-
-    fdPtr->efi.length = 2;
-    memset(&fdPtr->cmd, 0, sizeof(Command));
-    fdPtr->cmd.nsPtr = nsPtr;
-    fdPtr->cmd.clientData = &fdPtr->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;
     ByteCodeGetInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr);
     if (codePtr) {
 	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;
+	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,
@@ -967,42 +954,7 @@ 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;
-
-    /*
-     * 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;
 }
 
 /*
@@ -1218,6 +1170,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
@@ -1232,13 +1210,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);
 }
 
 /*
@@ -1434,6 +1412,8 @@ CloneProcedureMethod(
     pm2Ptr = (ProcedureMethod *)Tcl_Alloc(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 ac3019f..3048a88 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -3465,47 +3465,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}
-# 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 {}
+# 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} {
-		set worker [A create a$n]
-		lappend workers $worker
-		$worker schedule
-	    }
-	    after 250 [namespace code {variable forever false}]
-	    variable forever true
-	    vwait [my varname forever]
-	    foreach worker $workers {
-		$worker destroy
+		lappend workers [set worker [[self] new]]
+		$worker schedule {*}$args
 	    }
-	    return $::result
+	    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 {} {
-	    set coro coro-[namespace tail [self]]
-	    if {[llength [info commands $coro]] == 0} {
-		coroutine $coro my Work
-	    }
+	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 {} {
+    }
+    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 ::result [dump]
+	    lappend $var [my dump]
 	}
     }
-} -body {
-    # Triggers a crash with incorrectly restored procPtr->cmdPtr
-    proc dump {} {
-	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 {