[Bug 2919042] Restore "valgrindability" of Tcl that was lost by the streamlining of [exit], by conditionally forcing a full Finalize: use -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT)

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