summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJoe Mistachkin <joe@mistachkin.com>2009-10-18 11:21:38 (GMT)
committerJoe Mistachkin <joe@mistachkin.com>2009-10-18 11:21:38 (GMT)
commit7b94da051e6dde67f1a1602c93fffbcc98787cf1 (patch)
tree603c5054308f9adf1cc735c02a0e1c578b379924
parent391cc5529b10b842b5e34acb19bf559b56df7f49 (diff)
downloadtcl-7b94da051e6dde67f1a1602c93fffbcc98787cf1.zip
tcl-7b94da051e6dde67f1a1602c93fffbcc98787cf1.tar.gz
tcl-7b94da051e6dde67f1a1602c93fffbcc98787cf1.tar.bz2
Fix for [Bug 988703, 1565466]
-rw-r--r--ChangeLog16
-rw-r--r--doc/memory.n15
-rw-r--r--generic/tclCkalloc.c23
-rw-r--r--generic/tclInt.decls7
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclIntDecls.h30
-rw-r--r--generic/tclObj.c101
-rw-r--r--generic/tclStubInit.c9
-rw-r--r--tests/thread.test11
9 files changed, 200 insertions, 20 deletions
diff --git a/ChangeLog b/ChangeLog
index 78300b1..3b4a3f9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,19 @@
+2009-10-18 Joe Mistachkin <joe@mistachkin.com>
+
+ * tests/thread.test (thread-4.[345]): [Bug 1565466]: Correct tests to
+ save their error state before the final call to threadReap just in case
+ it triggers an "invalid thread id" error. This error can occur if one
+ or more of the target threads has exited prior to the attempt to send
+ it an asynchronous exit command.
+
+ * doc/memory.n: [Bug 988703]: Add mechanism for discovering what Tcl_Objs
+ * generic/tclCkalloc.c (MemoryCmd): are allocated when built for memory
+ * generic/tclInt.decls: debugging. This was previously backported from
+ * generic/tclInt.h: Tcl 8.6 with the corrections to fix [Bug 2871908].
+ * generic/tclObj.c (ObjData, TclFinalizeThreadObjects): However, there
+ were key elements missing. These changes make things consistent between
+ branches.
+
2009-10-17 Donal K. Fellows <dkf@users.sf.net>
* generic/tclVar.c (TclDeleteCompiledLocalVars, UnsetVarStruct)
diff --git a/doc/memory.n b/doc/memory.n
index 7e49882..ed8a5fc 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.12 2008/01/18 15:51:08 dkf Exp $
+'\" RCS: @(#) $Id: memory.n,v 1.12.2.1 2009/10/18 11:21:38 mistachkin 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
.
@@ -69,9 +76,11 @@ to \fBckalloc\fR causes a line of trace information to be written to
address returned, the amount of memory allocated, and the C filename
and line number of the code performing the allocation. For example:
.RS
+.PP
.CS
ckalloc 40e478 98 tclProc.c 1406
.CE
+.PP
Calls to \fBckfree\fR are traced in the same manner.
.RE
.TP
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 = {
diff --git a/tests/thread.test b/tests/thread.test
index 9f5562e..15fa2c6 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: thread.test,v 1.18 2007/12/13 15:26:07 dgp Exp $
+# RCS: @(#) $Id: thread.test,v 1.18.2.1 2009/10/18 11:21:38 mistachkin Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -184,8 +184,9 @@ test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
set len [llength [testthread names]]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {set undef}} msg]
+ set savedErrorInfo $::errorInfo
threadReap
- list $len $x $msg $::errorInfo
+ list $len $x $msg $savedErrorInfo
} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
while executing
"set undef"
@@ -197,16 +198,18 @@ test thread-4.4 {TclThreadSend preserve code} {testthread} {
set serverthread [testthread create]
set ::errorInfo {}
set x [catch {testthread send $serverthread {set ::errorInfo {}; break}} msg]
+ set savedErrorInfo $::errorInfo
threadReap
- list $len $x $msg $::errorInfo
+ list $len $x $msg $savedErrorInfo
} {1 3 {} {}}
test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
threadReap
set ::tcltest::mainThread [testthread names]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
+ set savedErrorCode $::errorCode
threadReap
- list $x $msg $::errorCode
+ list $x $msg $savedErrorCode
} {1 ERR CODE}