diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | doc/memory.n | 15 | ||||
| -rw-r--r-- | generic/tclCkalloc.c | 23 | ||||
| -rw-r--r-- | generic/tclInt.decls | 7 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 30 | ||||
| -rw-r--r-- | generic/tclObj.c | 101 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 9 | ||||
| -rw-r--r-- | tests/thread.test | 11 |
9 files changed, 200 insertions, 20 deletions
@@ -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} |