Attachment "thr2.patch" to
ticket [3390699fff]
added by
ferrieux
2011-08-13 23:48:05.
Index: generic/tclBasic.c
===================================================================
--- generic/tclBasic.c
+++ generic/tclBasic.c
@@ -1357,11 +1357,11 @@
/*
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
* unless we are exiting.
*/
- if ((iPtr->numLevels > 0) && !TclInExit()) {
+ if ((iPtr->numLevels > 0) && !TclInExit() && !(((Interp *)interp)->flags & 0x4000)) {
Tcl_Panic("DeleteInterpProc called with active evals");
}
/*
* The interpreter should already be marked deleted; otherwise how did we
@@ -1480,11 +1480,11 @@
/*
* Pop the root frame pointer and finish deleting the global
* namespace. The order is important [Bug 1658572].
*/
- if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) {
+ if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit() && !(iPtr->flags & 0x4000)) {
Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
}
Tcl_PopCallFrame(interp);
ckfree(iPtr->rootFramePtr);
iPtr->rootFramePtr = NULL;
@@ -1601,11 +1601,11 @@
* Location stack for uplevel/eval/... scripts which were passed through
* proc arguments. Actually we track all arguments as we do not and cannot
* know which arguments will be used as scripts and which will not.
*/
- if (iPtr->lineLAPtr->numEntries && !TclInExit()) {
+ if (iPtr->lineLAPtr->numEntries && !TclInExit() && !(iPtr->flags & 0x4000)) {
/*
* When the interp goes away we have nothing on the stack, so there
* are no arguments, so this table has to be empty.
*/
@@ -1614,11 +1614,11 @@
Tcl_DeleteHashTable(iPtr->lineLAPtr);
ckfree((char *) iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
- if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
+ if (iPtr->lineLABCPtr->numEntries && !TclInExit() && !(iPtr->flags & 0x4000)) {
/*
* When the interp goes away we have nothing on the stack, so there
* are no arguments, so this table has to be empty.
*/
Index: generic/tclExecute.c
===================================================================
--- generic/tclExecute.c
+++ generic/tclExecute.c
@@ -898,11 +898,11 @@
DeleteExecStack(
ExecStack *esPtr)
{
if (esPtr->markerPtr && !cachedInExit) {
Tcl_Panic("freeing an execStack which is still in use");
- }
+}
if (esPtr->prevPtr) {
esPtr->prevPtr->nextPtr = esPtr->nextPtr;
}
if (esPtr->nextPtr) {
@@ -915,11 +915,11 @@
TclDeleteExecEnv(
ExecEnv *eePtr) /* Execution environment to free. */
{
ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
- cachedInExit = TclInExit();
+ cachedInExit = 1; // TclInExit();
/*
* Delete all stacks in this exec env.
*/
Index: generic/tclThreadTest.c
===================================================================
--- generic/tclThreadTest.c
+++ generic/tclThreadTest.c
@@ -175,10 +175,30 @@
return TCL_OK;
}
/*
+ * ThreadEnd --
+ *
+ * This function does all the necessary cleanup of the thread+interp+tsd.
+ * To be called either in normal fallthrough or testthead::exit.
+ */
+
+static void ThreadEnd(
+ int status,
+ ThreadSpecificData *tsdPtr,
+ int hack)
+{
+ ((Interp *)tsdPtr->interp)->flags |= 0x4000;
+ ListRemove(hack ? NULL: tsdPtr);
+ Tcl_Release(tsdPtr->interp);
+ Tcl_DeleteInterp(tsdPtr->interp);
+ Tcl_ExitThread(status);
+}
+
+
+/*
*----------------------------------------------------------------------
*
* ThreadObjCmd --
*
* This procedure is invoked to process the "testthread" Tcl command. See
@@ -323,12 +343,11 @@
case THREAD_EXIT:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- ListRemove(NULL);
- Tcl_ExitThread(0);
+ ThreadEnd(0, tsdPtr, 1);
return TCL_OK;
case THREAD_ID:
if (objc == 2 || objc == 3) {
Tcl_Obj *idObj;
@@ -621,14 +640,11 @@
/*
* Clean up.
*/
- ListRemove(tsdPtr);
- Tcl_Release(tsdPtr->interp);
- Tcl_DeleteInterp(tsdPtr->interp);
- Tcl_ExitThread(result);
+ ThreadEnd(result, tsdPtr, 0);
TCL_THREAD_CREATE_RETURN;
}
/*
Index: library/tcltest/tcltest.tcl
===================================================================
--- library/tcltest/tcltest.tcl
+++ library/tcltest/tcltest.tcl
@@ -3283,10 +3283,11 @@
foreach tid [testthread names] {
if {$tid != [mainThread]} {
catch {
testthread send -async $tid {testthread exit}
}
+ testthread join $tid
}
}
## Enter a bit a sleep to give the threads enough breathing
## room to kill themselves off, otherwise the end up with a
## massive queue of repeated events
Index: tests/socket.test
===================================================================
--- tests/socket.test
+++ tests/socket.test
@@ -1,5 +1,9 @@
+if {[llength [info commands memory]]} {
+ memory onexit /tmp/mem[pid].log
+}
+
# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
@@ -1699,11 +1703,11 @@
# thread cleans itself up.
testthread exit
}] script]
} -constraints [list socket supported_$af testthread] -body {
# create a thread
- set serverthread [testthread create [list source $path(script) ] ]
+ set serverthread [testthread create -joinable [list source $path(script) ] ]
update
set port [testthread send $serverthread {set listen}]
update
set s [socket $localhost $port]
fconfigure $s -buffering line
