Tcl Source Code

Check-in [3fc64e5692]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Prevent leak of interps when using the [testthread exit] command.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dgp-thread-leaks
Files: files | file ages | folders
SHA1: 3fc64e56927a44eef9707f8011bebd695ef8e16e
User & Date: dgp 2011-08-30 16:20:03
Context
2011-08-30
21:27
Use the Thread package instead of the [testthread] command to do thread-enabled testing of the http... Closed-Leaf check-in: 029b9c4847 user: dgp tags: dgp-thread-leaks
16:20
Prevent leak of interps when using the [testthread exit] command. check-in: 3fc64e5692 user: dgp tags: dgp-thread-leaks
15:44
Prevent segfaults attempting to use thread maps after they've been deleted. Closed-Leaf check-in: a5b9dc7fa4 user: dgp tags: bug-3397515
00:23
[Bug 3398794]: Use Tcl errors in scripts, not panics. check-in: 241cdd7be1 user: dkf tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.









1
2
3
4
5
6
7







2011-08-30  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (SlaveCommandLimitCmd, SlaveTimeLimitCmd):
	[Bug 3398794]: Ensure that low-level conditions in the limit API are
	enforced at the script level through errors, not a Tcl_Panic. This
	means that interpreters cannot read their own limits (writing already
	did not work).
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
2011-08-30  Don Porter  <[email protected]>

	* generic/tclBasic.c:		Prevent leak of interps when
	* generic/tclExecute.c:		using the [testthread exit] command.
	* generic/tclIORChan.c:
	* generic/tclIORTrans.c:
	* generic/tclThreadtest.c:

2011-08-30  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (SlaveCommandLimitCmd, SlaveTimeLimitCmd):
	[Bug 3398794]: Ensure that low-level conditions in the limit API are
	enforced at the script level through errors, not a Tcl_Panic. This
	means that interpreters cannot read their own limits (writing already
	did not work).

Changes to generic/tclBasic.c.

1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
....
1478
1479
1480
1481
1482
1483
1484
1485

1486
1487
1488
1489
1490
1491
1492
....
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
    int i;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
	 * unless we are exiting.
     */

    if ((iPtr->numLevels > 0) && !TclInExit()) {
	Tcl_Panic("DeleteInterpProc called with active evals");
    }

    /*
     * The interpreter should already be marked deleted; otherwise how did we
     * get here?
     */
................................................................................
    }

    /*
     * Pop the root frame pointer and finish deleting the global
     * namespace. The order is important [Bug 1658572].
     */

    if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) {

	Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
    }
    Tcl_PopCallFrame(interp);
    ckfree(iPtr->rootFramePtr);
    iPtr->rootFramePtr = NULL;
    Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);

................................................................................

    /*
     * 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()) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }

    Tcl_DeleteHashTable(iPtr->lineLAPtr);
    ckfree((char *) iPtr->lineLAPtr);
    iPtr->lineLAPtr = NULL;

    if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }






|







 







|
>







 







|












|







1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
....
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
....
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
    int i;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
	 * unless we are exiting.
     */

    if ((iPtr->numLevels > 0) && !TclInExit() && !TclInThreadExit()) {
	Tcl_Panic("DeleteInterpProc called with active evals");
    }

    /*
     * The interpreter should already be marked deleted; otherwise how did we
     * get here?
     */
................................................................................
    }

    /*
     * Pop the root frame pointer and finish deleting the global
     * namespace. The order is important [Bug 1658572].
     */

    if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()
	    && !TclInThreadExit()) {
	Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
    }
    Tcl_PopCallFrame(interp);
    ckfree(iPtr->rootFramePtr);
    iPtr->rootFramePtr = NULL;
    Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);

................................................................................

    /*
     * 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() && !TclInThreadExit()) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }

    Tcl_DeleteHashTable(iPtr->lineLAPtr);
    ckfree((char *) iPtr->lineLAPtr);
    iPtr->lineLAPtr = NULL;

    if (iPtr->lineLABCPtr->numEntries && !TclInExit() && !TclInThreadExit()) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }

Changes to generic/tclExecute.c.

894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
...
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
 *----------------------------------------------------------------------
 */

static void
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) {
................................................................................
	tmpPtr = esPtr;
	esPtr = tmpPtr->prevPtr;
	DeleteExecStack(tmpPtr);
    }

    TclDecrRefCount(eePtr->constants[0]);
    TclDecrRefCount(eePtr->constants[1]);
    if (eePtr->callbackPtr && !cachedInExit) {
	Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
    }
    if (eePtr->corPtr && !cachedInExit) {
	Tcl_Panic("Deleting execEnv with existing coroutine");
    }
    ckfree(eePtr);
}
 
/*
 *----------------------------------------------------------------------






|







 







|


|







894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
...
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
 *----------------------------------------------------------------------
 */

static void
DeleteExecStack(
    ExecStack *esPtr)
{
    if (esPtr->markerPtr && !cachedInExit && !TclInThreadExit()) {
	Tcl_Panic("freeing an execStack which is still in use");
    }

    if (esPtr->prevPtr) {
	esPtr->prevPtr->nextPtr = esPtr->nextPtr;
    }
    if (esPtr->nextPtr) {
................................................................................
	tmpPtr = esPtr;
	esPtr = tmpPtr->prevPtr;
	DeleteExecStack(tmpPtr);
    }

    TclDecrRefCount(eePtr->constants[0]);
    TclDecrRefCount(eePtr->constants[1]);
    if (eePtr->callbackPtr && !cachedInExit && !TclInThreadExit()) {
	Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
    }
    if (eePtr->corPtr && !cachedInExit &&!TclInThreadExit()) {
	Tcl_Panic("Deleting execEnv with existing coroutine");
    }
    ckfree(eePtr);
}
 
/*
 *----------------------------------------------------------------------

Changes to generic/tclIORChan.c.

2521
2522
2523
2524
2525
2526
2527



2528
2529
2530
2531
2532
2533
2534
    /*
     * Get the map of all channels handled by the current thread. This is a
     * ReflectedChannelMap, but on a per-thread basis, not per-interp. Go
     * through the channels and remove all which were handled by this
     * interpreter. They have already been marked as dead.
     */




    rcmPtr = GetThreadReflectedChannelMap();
    for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
	chan = Tcl_GetHashValue(hPtr);
	rcPtr = Tcl_GetChannelInstanceData(chan);







>
>
>







2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
    /*
     * Get the map of all channels handled by the current thread. This is a
     * ReflectedChannelMap, but on a per-thread basis, not per-interp. Go
     * through the channels and remove all which were handled by this
     * interpreter. They have already been marked as dead.
     */

    if (TclInThreadExit()) {
	return;
    }
    rcmPtr = GetThreadReflectedChannelMap();
    for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
	chan = Tcl_GetHashValue(hPtr);
	rcPtr = Tcl_GetChannelInstanceData(chan);

Changes to generic/tclIORTrans.c.

2196
2197
2198
2199
2200
2201
2202



2203
2204
2205
2206
2207
2208
2209
    /*
     * Get the map of all channels handled by the current thread. This is a
     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
     * through the channels and remove all which were handled by this
     * interpreter. They have already been marked as dead.
     */




    rtmPtr = GetThreadReflectedTransformMap();
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
	rtPtr = Tcl_GetHashValue(hPtr);

	if (rtPtr->interp != interp) {






>
>
>







2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
    /*
     * Get the map of all channels handled by the current thread. This is a
     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
     * through the channels and remove all which were handled by this
     * interpreter. They have already been marked as dead.
     */

    if (TclInThreadExit()) {
	return;
    }
    rtmPtr = GetThreadReflectedTransformMap();
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
	rtPtr = Tcl_GetHashValue(hPtr);

	if (rtPtr->interp != interp) {

Changes to generic/tclThreadTest.c.

135
136
137
138
139
140
141

142
143
144
145
146
147
148
...
322
323
324
325
326
327
328

329
330
331
332
333
334
335
336
337
...
560
561
562
563
564
565
566

567
568
569
570
571
572
573
...
610
611
612
613
614
615
616



617



618
619
620
621
622
623
624
...
626
627
628
629
630
631
632









633
634
635
636
637
638
639
....
1020
1021
1022
1023
1024
1025
1026


1027
1028



1029
1030
1031



1032
1033
1034
1035
1036
1037
1038
static void		ListUpdateInner(ThreadSpecificData *tsdPtr);
static int		ThreadEventProc(Tcl_Event *evPtr, int mask);
static void		ThreadErrorProc(Tcl_Interp *interp);
static void		ThreadFreeProc(ClientData clientData);
static int		ThreadDeleteEvent(Tcl_Event *eventPtr,
			    ClientData clientData);
static void		ThreadExitProc(ClientData clientData);

extern int		Tcltest_Init(Tcl_Interp *interp);
 
/*
 *----------------------------------------------------------------------
 *
 * TclThread_Init --
 *
................................................................................
    }
    case THREAD_EXIT:
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	ListRemove(NULL);

	Tcl_ExitThread(0);
	return TCL_OK;
    case THREAD_ID:
	if (objc == 2 || objc == 3) {
	    Tcl_Obj *idObj;

	    /*
	     * Check if they want the main thread id or the current thread id.
	     */
................................................................................
NewTestThread(
    ClientData clientData)
{
    ThreadCtrl *ctrlPtr = clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int result;
    char *threadEvalScript;


    /*
     * Initialize the interpreter. This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);
................................................................................
    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve(tsdPtr->interp);



    result = Tcl_Eval(tsdPtr->interp, threadEvalScript);



    if (result != TCL_OK) {
	ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up.
     */
................................................................................
    ListRemove(tsdPtr);
    Tcl_Release(tsdPtr->interp);
    Tcl_DeleteInterp(tsdPtr->interp);
    Tcl_ExitThread(result);

    TCL_THREAD_CREATE_RETURN;
}









 
/*
 *------------------------------------------------------------------------
 *
 * ThreadErrorProc --
 *
 *	Send a message to the thread willing to hear about errors.
................................................................................

    if (interp == NULL) {
	code = TCL_ERROR;
	result = "no target interp!";
	errorCode = "THREAD";
	errorInfo = "";
    } else {


	Tcl_Preserve(interp);
	Tcl_ResetResult(interp);



	Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
	code = Tcl_GlobalEval(interp, threadEventPtr->script);
	Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);



	if (code != TCL_OK) {
	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
	    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
	} else {
	    errorCode = errorInfo = NULL;
	}
	result = Tcl_GetStringResult(interp);






>







 







>

|







 







>







 







>
>
>

>
>
>







 







>
>
>
>
>
>
>
>
>







 







>
>


>
>
>



>
>
>







135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
...
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
...
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
...
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
....
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
static void		ListUpdateInner(ThreadSpecificData *tsdPtr);
static int		ThreadEventProc(Tcl_Event *evPtr, int mask);
static void		ThreadErrorProc(Tcl_Interp *interp);
static void		ThreadFreeProc(ClientData clientData);
static int		ThreadDeleteEvent(Tcl_Event *eventPtr,
			    ClientData clientData);
static void		ThreadExitProc(ClientData clientData);
static void		ReleaseInterp(ClientData clientData);
extern int		Tcltest_Init(Tcl_Interp *interp);
 
/*
 *----------------------------------------------------------------------
 *
 * TclThread_Init --
 *
................................................................................
    }
    case THREAD_EXIT:
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	ListRemove(NULL);
	Tcl_DeleteInterp(interp);
	Tcl_ExitThread(0);
	return TCL_ERROR;
    case THREAD_ID:
	if (objc == 2 || objc == 3) {
	    Tcl_Obj *idObj;

	    /*
	     * Check if they want the main thread id or the current thread id.
	     */
................................................................................
NewTestThread(
    ClientData clientData)
{
    ThreadCtrl *ctrlPtr = clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int result;
    char *threadEvalScript;
    int fullFinal = TclFullFinalizationRequested();

    /*
     * Initialize the interpreter. This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);
................................................................................
    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve(tsdPtr->interp);
    if (fullFinal) {
	Tcl_CreateThreadExitHandler(ReleaseInterp, tsdPtr->interp);
    }
    result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
    if (fullFinal) {
	Tcl_DeleteThreadExitHandler(ReleaseInterp, tsdPtr->interp);
    }
    if (result != TCL_OK) {
	ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up.
     */
................................................................................
    ListRemove(tsdPtr);
    Tcl_Release(tsdPtr->interp);
    Tcl_DeleteInterp(tsdPtr->interp);
    Tcl_ExitThread(result);

    TCL_THREAD_CREATE_RETURN;
}
 
static void
ReleaseInterp(
    ClientData clientData)
{
    Tcl_Interp *interp = (Tcl_Interp *) clientData;

    Tcl_Release(interp);
}
 
/*
 *------------------------------------------------------------------------
 *
 * ThreadErrorProc --
 *
 *	Send a message to the thread willing to hear about errors.
................................................................................

    if (interp == NULL) {
	code = TCL_ERROR;
	result = "no target interp!";
	errorCode = "THREAD";
	errorInfo = "";
    } else {
	int fullFinal = TclFullFinalizationRequested();

	Tcl_Preserve(interp);
	Tcl_ResetResult(interp);
	if (fullFinal) {
	    Tcl_CreateThreadExitHandler(ReleaseInterp, tsdPtr->interp);
	}
	Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
	code = Tcl_GlobalEval(interp, threadEventPtr->script);
	Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
	if (fullFinal) {
	    Tcl_DeleteThreadExitHandler(ReleaseInterp, tsdPtr->interp);
	}
	if (code != TCL_OK) {
	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
	    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
	} else {
	    errorCode = errorInfo = NULL;
	}
	result = Tcl_GetStringResult(interp);