diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclCkalloc.c | 23 | ||||
| -rw-r--r-- | generic/tclEvent.c | 3 | ||||
| -rw-r--r-- | generic/tclInt.decls | 8 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 | ||||
| -rw-r--r-- | generic/tclObj.c | 140 |
5 files changed, 171 insertions, 11 deletions
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); } } |