summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclBasic.c13
-rw-r--r--generic/tclEvent.c49
-rw-r--r--generic/tclExecute.c12
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclMain.c87
6 files changed, 126 insertions, 44 deletions
diff --git a/ChangeLog b/ChangeLog
index 04d506b..bdf73e9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,12 @@
2011-08-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
+ * generic/tclBasic.c: [Bug 2919042] Restore "valgrindability" of Tcl
+ * generic/tclEvent.c: that was lost by the streamlining of [exit], by
+ * generic/tclExecute.c: conditionally forcing a full Finalize:
+ * generic/tclInt.h: use -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT)
+
+2011-08-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
+
* generic/tclCompCmds.c: [Bug 3386417] avoid a reference loop between
* generic/tclInt.h: the bytecode and its companion errostack
* generic/tclResult.c: when compiling a syntax error.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a44d736..124f932 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1355,10 +1355,11 @@ DeleteInterpProc(
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");
}
@@ -1481,7 +1482,7 @@ DeleteInterpProc(
* 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);
@@ -1602,7 +1603,7 @@ DeleteInterpProc(
* 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.
@@ -1612,10 +1613,10 @@ DeleteInterpProc(
}
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.
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 6816487..e65862c 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -953,27 +953,38 @@ Tcl_Exit(
currentAppExitPtr(INT2PTR(status));
Tcl_Panic("AppExitProc returned unexpectedly");
} else {
- /*
- * Use default handling.
- */
- InvokeExitHandlers();
+ if (TclFullFinalizationRequested()) {
- /*
- * 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();
-
+ /*
+ * 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!");
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a7d6184..691c8d7 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -53,6 +53,8 @@
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,
@@ -896,7 +898,7 @@ static void
DeleteExecStack(
ExecStack *esPtr)
{
- if (esPtr->markerPtr) {
+ if (esPtr->markerPtr && !cachedInExit) {
Tcl_Panic("freeing an execStack which is still in use");
}
@@ -915,6 +917,8 @@ TclDeleteExecEnv(
{
ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
+ cachedInExit = TclInExit();
+
/*
* Delete all stacks in this exec env.
*/
@@ -930,10 +934,10 @@ TclDeleteExecEnv(
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);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9f00077..d65f712 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3787,6 +3787,8 @@ 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.
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 26383b5..c7166d7 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -125,6 +125,7 @@ typedef struct InteractiveState {
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;
@@ -387,6 +388,13 @@ Tcl_MainEx(
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
@@ -597,31 +605,18 @@ Tcl_MainEx(
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);
}
@@ -699,6 +694,42 @@ TclGetMainLoop(void)
/*
*----------------------------------------------------------------------
*
+ * 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 --
*
* This function is invoked by the event dispatcher whenever standard
@@ -881,6 +912,32 @@ Prompt(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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