Fix for [Bug 988703, 1565466]

6 files changed, 165 insertions, 13 deletions

diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index a29208a..81b8851 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -14,7 +14,7 @@
  *
  * This code contributed by Karl Lehenbauer and Mark Diekhans
  *
- * RCS: @(#) $Id: tclCkalloc.c,v 1.32.4.1 2009/09/29 04:43:58 dgp Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.32.4.2 2009/10/18 11:21:38 mistachkin Exp $
  */
 
 #include "tclInt.h"
@@ -811,6 +811,7 @@ MemoryCmd(
     CONST char *argv[])
 {
     CONST char *fileName;
+    FILE *fileP;
     Tcl_DString buffer;
     int result;
 
@@ -864,6 +865,26 @@ MemoryCmd(
 	init_malloced_bodies = (strcmp(argv[2],"on") == 0);
 	return TCL_OK;
     }
+    if (strcmp(argv[1],"objs") == 0) {
+	if (argc != 3) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " objs file\"", NULL);
+	    return TCL_ERROR;
+	}
+	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+	if (fileName == NULL) {
+	    return TCL_ERROR;
+	}
+	fileP = fopen(fileName, "w");
+	if (fileP == NULL) {
+	    Tcl_AppendResult(interp, "cannot open output file", NULL);
+	    return TCL_ERROR;
+	}
+	TclDbDumpActiveObjects(fileP);
+	fclose(fileP);
+	Tcl_DStringFree(&buffer);
+	return TCL_OK;
+    }
     if (strcmp(argv[1],"onexit") == 0) {
 	if (argc != 3) {
 	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index ecd6196..07e7ddb 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -13,7 +13,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: tclInt.decls,v 1.121.2.1 2009/04/10 18:02:42 das Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.121.2.2 2009/10/18 11:21:38 mistachkin Exp $
 
 library tcl
 
@@ -934,6 +934,11 @@ declare 236 generic {
     void TclBackgroundException(Tcl_Interp *interp, int code)
 }
 
+# Tcl_Obj leak detection support.
+declare 243 generic {
+    void TclDbDumpActiveObjects(FILE *outFile)
+}
+
 ##############################################################################
 
 # Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 30c663f..10da682 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.362.2.9 2009/09/29 04:43:58 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.362.2.10 2009/10/18 11:21:38 mistachkin Exp $
  */
 
 #ifndef _TCLINT
@@ -2566,6 +2566,7 @@ MODULE_SCOPE void	TclFinalizePreserve(void);
 MODULE_SCOPE void	TclFinalizeSynchronization(void);
 MODULE_SCOPE void	TclFinalizeThreadAlloc(void);
 MODULE_SCOPE void	TclFinalizeThreadData(void);
+MODULE_SCOPE void	TclFinalizeThreadObjects(void);
 MODULE_SCOPE double	TclFloor(mp_int *a);
 MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
 MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
@@ -3492,12 +3493,13 @@ MODULE_SCOPE Tcl_Mutex	tclObjMutex;
 #endif
 
 #else /* TCL_MEM_DEBUG */
-MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr);
+MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
+			    int line);
 
 # define TclDbNewObj(objPtr, file, line) \
     TclIncrObjsAllocated(); \
     (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
-    TclDbInitNewObj(objPtr); \
+    TclDbInitNewObj((objPtr), (file), (line)); \
     TCL_DTRACE_OBJ_CREATE(objPtr)
 
 # define TclNewObj(objPtr) \
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 0ff03f9..cf30fc8 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIntDecls.h,v 1.112 2008/01/23 17:31:42 dgp Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.112.2.1 2009/10/18 11:21:38 mistachkin Exp $
  */
 
 #ifndef _TCLINTDECLS
@@ -1076,6 +1076,17 @@ EXTERN void		TclInitVarHashTable (TclVarHashTable * tablePtr,
 EXTERN void		TclBackgroundException (Tcl_Interp * interp, 
 				int code);
 #endif
+/* Slot 237 is reserved */
+/* Slot 238 is reserved */
+/* Slot 239 is reserved */
+/* Slot 240 is reserved */
+/* Slot 241 is reserved */
+/* Slot 242 is reserved */
+#ifndef TclDbDumpActiveObjects_TCL_DECLARED
+#define TclDbDumpActiveObjects_TCL_DECLARED
+/* 243 */
+EXTERN void		TclDbDumpActiveObjects (FILE * outFile);
+#endif
 
 typedef struct TclIntStubs {
     int magic;
@@ -1342,6 +1353,13 @@ typedef struct TclIntStubs {
     Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */
     void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */
     void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */
+    void *reserved237;
+    void *reserved238;
+    void *reserved239;
+    void *reserved240;
+    void *reserved241;
+    void *reserved242;
+    void (*tclDbDumpActiveObjects) (FILE * outFile); /* 243 */
 } TclIntStubs;
 
 #ifdef __cplusplus
@@ -2090,6 +2108,16 @@ extern TclIntStubs *tclIntStubsPtr;
 #define TclBackgroundException \
 	(tclIntStubsPtr->tclBackgroundException) /* 236 */
 #endif
+/* Slot 237 is reserved */
+/* Slot 238 is reserved */
+/* Slot 239 is reserved */
+/* Slot 240 is reserved */
+/* Slot 241 is reserved */
+/* Slot 242 is reserved */
+#ifndef TclDbDumpActiveObjects
+#define TclDbDumpActiveObjects \
+	(tclIntStubsPtr->tclDbDumpActiveObjects) /* 243 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 39b8515..23097f6 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclObj.c,v 1.139.2.4 2009/10/07 23:10:50 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.139.2.5 2009/10/18 11:21:38 mistachkin Exp $
  */
 
 #include "tclInt.h"
@@ -54,6 +54,22 @@ Tcl_Mutex tclObjMutex;
 char tclEmptyString = '\0';
 char *tclEmptyStringRep = &tclEmptyString;
 
+#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+/*
+ * Structure for tracking the source file and line number where a given Tcl_Obj
+ * was allocated.  We also track the pointer to the Tcl_Obj itself, for sanity
+ * checking purposes.
+ */
+
+typedef struct ObjData {
+    Tcl_Obj *objPtr;		/* The pointer to the allocated Tcl_Obj. */
+    CONST char *file;		/* The name of the source file calling this
+				 * function; used for debugging. */
+    int line;			/* Line number in the source file; used for
+				 * debugging. */
+} ObjData;
+#endif /* TCL_MEM_DEBUG && TCL_THREADS */
+
 /*
  * All static variables used in this file are collected into a single instance
  * of the following structure.  For multi-threaded implementations, there is
@@ -81,6 +97,7 @@ typedef struct ThreadSpecificData {
      * Thread local table that is used to check that a Tcl_Obj was not
      * allocated by some other thread.
      */
+
     Tcl_HashTable *objThreadMap;
 #endif /* TCL_MEM_DEBUG && TCL_THREADS */
 } ThreadSpecificData;
@@ -960,6 +977,55 @@ Tcl_ConvertToType(
 }
 
 /*
+ *--------------------------------------------------------------
+ *
+ * TclDbDumpActiveObjects --
+ *
+ *	This function is called to dump all of the active Tcl_Obj structs this
+ *	allocator knows about.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+TclDbDumpActiveObjects(
+    FILE *outFile)
+{
+#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+    Tcl_HashSearch hSearch;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashTable *tablePtr;
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+    tablePtr = tsdPtr->objThreadMap;
+
+    if (tablePtr != NULL) {
+	fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
+	for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
+		hPtr = Tcl_NextHashEntry(&hSearch)) {
+	    ObjData *objData = Tcl_GetHashValue(hPtr);
+
+	    if (objData != NULL) {
+		fprintf(outFile,
+			"key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n",
+			Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr,
+			objData->file, objData->line);
+	    } else {
+		fprintf(outFile, "key = 0x%p\n",
+			Tcl_GetHashKey(tablePtr, hPtr));
+	    }
+	}
+    }
+#endif
+}
+
+/*
  *----------------------------------------------------------------------
  *
  * TclDbInitNewObj --
@@ -980,7 +1046,11 @@ Tcl_ConvertToType(
 #ifdef TCL_MEM_DEBUG
 void
 TclDbInitNewObj(
-    register Tcl_Obj *objPtr)
+    register Tcl_Obj *objPtr,
+    register CONST char *file,	/* The name of the source file calling this
+				 * function; used for debugging. */
+    register int line)		/* Line number in the source file; used for
+				 * debugging. */
 {
     objPtr->refCount = 0;
     objPtr->bytes = tclEmptyStringRep;
@@ -997,7 +1067,8 @@ TclDbInitNewObj(
 	Tcl_HashEntry *hPtr;
 	Tcl_HashTable *tablePtr;
 	int isNew;
-	ThreadSpecificData *tsdPtr = TclGetContLineTable();
+	ObjData *objData;
+	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
 	if (tsdPtr->objThreadMap == NULL) {
 	    tsdPtr->objThreadMap = (Tcl_HashTable *)
@@ -1009,7 +1080,16 @@ TclDbInitNewObj(
 	if (!isNew) {
 	    Tcl_Panic("expected to create new entry for object map");
 	}
-	Tcl_SetHashValue(hPtr, NULL);
+
+	/*
+	 * Record the debugging information.
+	 */
+
+	objData = (ObjData *) ckalloc(sizeof(ObjData));
+	objData->objPtr = objPtr;
+	objData->file = file;
+	objData->line = line;
+	Tcl_SetHashValue(hPtr, objData);
     }
 #endif /* TCL_THREADS */
 }
@@ -3596,8 +3676,17 @@ Tcl_DbDecrRefCount(
 		    "Tcl_Obj allocated in another thread");
 	}
 
-	/* If the Tcl_Obj is going to be deleted, remove the entry */
-	if ((((objPtr)->refCount) - 1) <= 0) {
+	/*
+	 * If the Tcl_Obj is going to be deleted, remove the entry.
+	 */
+
+	if ((objPtr->refCount - 1) <= 0) {
+	    ObjData *objData = Tcl_GetHashValue(hPtr);
+
+	    if (objData != NULL) {
+		ckfree((char *) objData);
+	    }
+
 	    Tcl_DeleteHashEntry(hPtr);
 	}
     }
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 18c4f44..5159c74 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclStubInit.c,v 1.150.2.1 2009/04/10 18:02:42 das Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.150.2.2 2009/10/18 11:21:38 mistachkin Exp $
  */
 
 #include "tclInt.h"
@@ -335,6 +335,13 @@ TclIntStubs tclIntStubs = {
     TclVarHashCreateVar, /* 234 */
     TclInitVarHashTable, /* 235 */
     TclBackgroundException, /* 236 */
+    NULL, /* 237 */
+    NULL, /* 238 */
+    NULL, /* 239 */
+    NULL, /* 240 */
+    NULL, /* 241 */
+    NULL, /* 242 */
+    TclDbDumpActiveObjects, /* 243 */
 };
 
 TclIntPlatStubs tclIntPlatStubs = {