Attachment "val5.patch" to
ticket [2919042fff]
added by
ferrieux
2011-08-07 23:02:18.
Index: generic/tclBasic.c
===================================================================
--- generic/tclBasic.c
+++ generic/tclBasic.c
@@ -1353,14 +1353,15 @@
Tcl_HashTable *hTablePtr;
ResolverScheme *resPtr, *nextResPtr;
int i;
/*
- * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
+ * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
+ * unless we are exiting.
*/
- if (iPtr->numLevels > 0) {
+ if ((iPtr->numLevels > 0) && !TclInExit()) {
Tcl_Panic("DeleteInterpProc called with active evals");
}
/*
* The interpreter should already be marked deleted; otherwise how did we
@@ -1479,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) {
+ 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;
@@ -1600,24 +1601,24 @@
* 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) {
+ 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(iPtr->lineLAPtr);
+ ckfree((char *) iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
- if (iPtr->lineLABCPtr->numEntries) {
+ 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.
*/
Index: generic/tclEvent.c
===================================================================
--- generic/tclEvent.c
+++ generic/tclEvent.c
@@ -951,31 +951,42 @@
*/
currentAppExitPtr(INT2PTR(status));
Tcl_Panic("AppExitProc returned unexpectedly");
} else {
- /*
- * Use default handling.
- */
-
- InvokeExitHandlers();
-
- /*
- * Ensure the thread-specific data is initialised as it is used in
- * Tcl_FinalizeThread()
- */
-
- (void) TCL_TSD_INIT(&dataKey);
-
- /*
- * Now finalize the calling thread only (others are not safely
- * reachable). Among other things, this triggers a flush of the
- * Tcl_Channels that may have data enqueued.
- */
-
- Tcl_FinalizeThread();
-
+
+ if (TclFullFinalizationRequested()) {
+
+ /*
+ * Thorough finalization for Valgrind et al.
+ */
+
+ Tcl_Finalize();
+
+ } else {
+
+ /*
+ * Fast and deterministic exit (default behavior)
+ */
+
+ InvokeExitHandlers();
+
+ /*
+ * Ensure the thread-specific data is initialised as it is used in
+ * Tcl_FinalizeThread()
+ */
+
+ (void) TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Now finalize the calling thread only (others are not safely
+ * reachable). Among other things, this triggers a flush of the
+ * Tcl_Channels that may have data enqueued.
+ */
+
+ Tcl_FinalizeThread();
+ }
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
}
Index: generic/tclExecute.c
===================================================================
--- generic/tclExecute.c
+++ generic/tclExecute.c
@@ -51,10 +51,12 @@
*/
static int execInitialized = 0;
TCL_DECLARE_MUTEX(execMutex)
+static int cachedInExit = 0;
+
#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether execution tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no execution tracing
@@ -894,11 +896,11 @@
static void
DeleteExecStack(
ExecStack *esPtr)
{
- if (esPtr->markerPtr) {
+ if (esPtr->markerPtr && !cachedInExit) {
Tcl_Panic("freeing an execStack which is still in use");
}
if (esPtr->prevPtr) {
esPtr->prevPtr->nextPtr = esPtr->nextPtr;
@@ -913,10 +915,12 @@
TclDeleteExecEnv(
ExecEnv *eePtr) /* Execution environment to free. */
{
ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
+ cachedInExit = TclInExit();
+
/*
* Delete all stacks in this exec env.
*/
while (esPtr->nextPtr) {
@@ -928,14 +932,14 @@
DeleteExecStack(tmpPtr);
}
TclDecrRefCount(eePtr->constants[0]);
TclDecrRefCount(eePtr->constants[1]);
- if (eePtr->callbackPtr) {
- Tcl_Panic("Deleting execEnv with pending NRE callbacks!");
+ if (eePtr->callbackPtr && !cachedInExit) {
+ Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
}
- if (eePtr->corPtr) {
+ if (eePtr->corPtr && !cachedInExit) {
Tcl_Panic("Deleting execEnv with existing coroutine");
}
ckfree(eePtr);
}
Index: generic/tclInt.h
===================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -3783,10 +3783,12 @@
*/
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
+
+MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
Index: generic/tclMain.c
===================================================================
--- generic/tclMain.c
+++ generic/tclMain.c
@@ -123,10 +123,11 @@
*/
MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void);
static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr);
static void StdinProc(ClientData clientData, int mask);
+static void FreeMainInterp(ClientData clientData);
#ifndef TCL_ASCII_MAIN
static Tcl_ThreadDataKey dataKey;
/*
*----------------------------------------------------------------------
@@ -385,10 +386,17 @@
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
+ if (TclFullFinalizationRequested()) {
+ /*
+ * Arrange for final deletion of the main interp
+ */
+ // ARGH Munchhausen effect
+ Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp);
+ }
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
@@ -595,35 +603,22 @@
*/
if (!Tcl_InterpDeleted(interp)) {
if (!Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
-
+
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
-
+ }
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
* is happening. Maybe interp has been deleted; maybe [exit] was
* redefined, maybe we've blown up because of an exceeded limit. We
* still want to cleanup and exit.
*/
-
- if (!Tcl_InterpDeleted(interp)) {
- Tcl_DeleteInterp(interp);
- }
- }
- Tcl_SetStartupScript(NULL, NULL);
-
- /*
- * If we get here, the master interp has been deleted. Allow its
- * destruction with the last matching Tcl_Release.
- */
-
- Tcl_Release(interp);
Tcl_Exit(exitCode);
}
#ifndef UNICODE
void
@@ -693,10 +688,46 @@
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
return tsdPtr->mainLoopProc;
}
#endif /* !TCL_ASCII_MAIN */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFullFinalizationRequested --
+ *
+ * This function returns true when either -DPURIFY is specified, or the
+ * environment variable TCL_FINALIZE_ON_EXIT is set and not "0". This
+ * predicate is called at places affecting the exit sequence, so that the
+ * default behavior is a fast and deadlock-free exit, and the modified
+ * behavior is a more thorough finalization for debugging purposes (leak
+ * hunting etc).
+ *
+ * Results:
+ * A boolean.
+ *
+ *----------------------------------------------------------------------
+ */
+MODULE_SCOPE int
+TclFullFinalizationRequested(void)
+{
+#ifdef PURIFY
+ return 1;
+#else
+ const char *fin;
+ Tcl_DString ds;
+ int finalize = 0;
+
+ fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
+ finalize = ((fin != NULL) && strcmp(fin, "0"));
+ if (fin != NULL) {
+ Tcl_DStringFree(&ds);
+ }
+ return finalize;
+#endif
+}
/*
*----------------------------------------------------------------------
*
* StdinProc --
@@ -876,14 +907,40 @@
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != NULL) {
Tcl_Flush(chan);
}
isPtr->prompt = PROMPT_NONE;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeMainInterp --
+ *
+ * Exit handler used to cleanup the main interpreter and ancillary startup
+ * script storage at exit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeMainInterp(
+ ClientData clientData)
+{
+ Tcl_Interp *interp = (Tcl_Interp *) clientData;
+
+ //if (TclInExit()) return;
+
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_DeleteInterp(interp);
+ }
+ Tcl_SetStartupScript(NULL, NULL);
+ Tcl_Release(interp);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
