summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-06-18 09:41:25 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-06-18 09:41:25 (GMT)
commitbf70bdd02363606dc3d81c1a97059be6ecaec3b6 (patch)
tree7145a35ee01103f7cbd6ba44dd6c5a4f718539ae
parent9061f4d8529c1f16c80c71cc3d2bbe9bf33a8b97 (diff)
downloadtcl-bf70bdd02363606dc3d81c1a97059be6ecaec3b6.zip
tcl-bf70bdd02363606dc3d81c1a97059be6ecaec3b6.tar.gz
tcl-bf70bdd02363606dc3d81c1a97059be6ecaec3b6.tar.bz2
Apply patch from [Bug 988703]. Many thanks to Joe Mistachkin for development.
-rw-r--r--ChangeLog11
-rw-r--r--doc/memory.n13
-rw-r--r--generic/tclCkalloc.c23
-rw-r--r--generic/tclEvent.c3
-rw-r--r--generic/tclInt.decls8
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclObj.c140
7 files changed, 190 insertions, 16 deletions
diff --git a/ChangeLog b/ChangeLog
index 08b8bed..5f2223d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,9 +1,16 @@
+2009-06-18 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCkalloc.c (MemoryCmd): [Bug 988703]:
+ * generic/tclObj.c (ObjData, TclFinalizeThreadObjects): Add
+ mechanism for discovering what Tcl_Objs are allocated when built
+ for memory debugging. Developed by Joe Mistachkin.
+
2009-06-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* generic/tclEvent.c: Applied a patch by George Peter Staplin
drastically reducing the ambition of [exit] wrt finalization, and
- thus solving many multi-thread teardown issues [Bugs 2001201,
- 486399, and possibly 597575, 990457, 1437595, 2750491].
+ thus solving many multi-thread teardown issues. [Bugs 2001201,
+ 486399, and possibly 597575, 990457, 1437595, 2750491]
2009-06-15 Don Porter <dgp@users.sourceforge.net>
diff --git a/doc/memory.n b/doc/memory.n
index 0bc1b64..b269d7a 100644
--- a/doc/memory.n
+++ b/doc/memory.n
@@ -3,7 +3,7 @@
'\" Copyright (c) 2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
-'\" RCS: @(#) $Id: memory.n,v 1.13 2008/10/17 10:22:25 dkf Exp $
+'\" RCS: @(#) $Id: memory.n,v 1.14 2009/06/18 09:41:30 dkf Exp $
'\"
.so man.macros
.TH memory n 8.1 Tcl "Tcl Built-In Commands"
@@ -41,10 +41,17 @@ number of calls to \fBckalloc\fR not met by a corresponding call
to \fBckfree\fR), the current bytes allocated, and the maximum number
of packets and bytes allocated.
.TP
-\fB memory init \fR[\fBon\fR|\fBoff\fR]
+\fBmemory init \fR[\fBon\fR|\fBoff\fR]
.
Turn on or off the pre-initialization of all allocated memory
-with bogus bytes. Useful for detecting the use of uninitialized values.
+with bogus bytes. Useful for detecting the use of uninitialized
+values.
+.TP
+\fBmemory objs \fIfile\fR
+.
+Causes a list of all allocated Tcl_Obj values to be written to the specified
+\fIfile\fR immediately, together with where they were allocated. Useful for
+checking for leaks of values.
.TP
\fBmemory onexit\fR \fIfile\fR
.
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 2cbff69..9a3b4e3 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.35 2009/02/27 23:03:41 nijtmans Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.36 2009/06/18 09:41:26 dkf Exp $
*/
#include "tclInt.h"
@@ -803,6 +803,7 @@ MemoryCmd(
const char *argv[])
{
const char *fileName;
+ FILE *fileP;
Tcl_DString buffer;
int result;
@@ -856,6 +857,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/tclEvent.c b/generic/tclEvent.c
index 1495899..6c55ef0 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEvent.c,v 1.89 2009/06/17 19:24:05 ferrieux Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.90 2009/06/18 09:41:26 dkf Exp $
*/
#include "tclInt.h"
@@ -1273,6 +1273,7 @@ Tcl_FinalizeThread(void)
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
+ TclFinalizeThreadObjects();
}
/*
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 0db9059..0847324 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.138 2009/04/10 18:02:36 das Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.139 2009/06/18 09:41:26 dkf Exp $
library tcl
@@ -970,6 +970,12 @@ declare 242 generic {
int TclNREvalObjv(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int flags, Command *cmdPtr)
}
+
+# 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 9562d6b..d75eaa6 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,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.423 2009/05/08 08:48:19 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.424 2009/06/18 09:41:27 dkf Exp $
*/
#ifndef _TCLINT
@@ -2679,6 +2679,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,
@@ -3659,12 +3660,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/tclObj.c b/generic/tclObj.c
index f143eb2..edc203c 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.152 2009/05/08 02:21:09 msofer Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.153 2009/06/18 09:41:29 dkf Exp $
*/
#include "tclInt.h"
@@ -56,9 +56,24 @@ 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;
+
+/*
* Thread local table that is used to check that a Tcl_Obj was not allocated
* by some other thread.
*/
+
typedef struct ThreadSpecificData {
Tcl_HashTable *objThreadMap;
} ThreadSpecificData;
@@ -393,6 +408,49 @@ TclInitObjSubsystem(void)
/*
*----------------------------------------------------------------------
*
+ * TclFinalizeThreadObjects --
+ *
+ * This function is called by Tcl_FinalizeThread to clean up thread
+ * specific Tcl_Obj information.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeThreadObjects(void)
+{
+#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch hSearch;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+
+ if (tablePtr != NULL) {
+ for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
+ ObjData *objData = Tcl_GetHashValue(hPtr);
+
+ if (objData != NULL) {
+ ckfree((char *) objData);
+ }
+ }
+
+ Tcl_DeleteHashTable(tablePtr);
+ ckfree((char *) tablePtr);
+ tsdPtr->objThreadMap = NULL;
+ }
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclFinalizeObjects --
*
* This function is called by Tcl_Finalize to clean up all registered
@@ -595,6 +653,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 --
@@ -615,7 +722,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;
@@ -632,6 +743,7 @@ TclDbInitNewObj(
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
int isNew;
+ ObjData *objData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
@@ -644,7 +756,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 */
}
@@ -3207,8 +3328,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);
}
}