void
TclFinalizeMemorySubsystem(void)
{
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(tclMemDumpFileName);
} else if (onExitMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
TclpFree((char *) curTagPtr);
curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
#endif
#if USE_TCLALLOC
TclFinalizeAllocSubsystem();
#endif
}
/*
* ExitHandler
*
* Cleans up library on exit, frees all state structures.
*
* Arguments:
* dummy - Not used.
*
* Returns:
* None.
*/
static void
ExitHandler(
ClientData dummy
)
{
/* Init clean-up. */
Tcl_MutexLock(&initMutex);
if (kernelModule != NULL) {
FreeLibrary(kernelModule);
kernelModule = NULL;
}
getDiskFreeSpaceExPtr = NULL;
initialised = FALSE;
Tcl_MutexUnlock(&initMutex);
Tcl_MutexFinalize(&initMutex);
/* Key clean-up. */
Tcl_MutexLock(&keyMutex);
if (keyTable != NULL) {
KeyClearTable();
Tcl_DeleteHashTable(keyTable);
ckfree((char *)keyTable);
keyTable = NULL;
}
Tcl_MutexUnlock(&keyMutex);
Tcl_MutexFinalize(&keyMutex);
#ifdef TCL_MEM_DEBUG
Tcl_DumpActiveMemory("MemDump.txt");
#endif
}
/*++
Finalise
Finalises the library; freeing all held resources.
Arguments:
removeCmds - Remove extension commands from all interpreters.
Return Value:
None.
--*/
static void
Finalise(
int removeCmds
)
{
DebugPrint("Finalise: removeCmds=%d\n", removeCmds);
#ifdef _WINDOWS
Tcl_MutexLock(&initMutex);
if (winProcs.module != NULL) {
FreeLibrary(winProcs.module);
}
ZeroMemory(&winProcs, sizeof(WinProcs));
Tcl_MutexUnlock(&initMutex);
#endif
Tcl_MutexFinalize(&initMutex);
initialised = 0;
Tcl_MutexLock(&stateListMutex);
if (stateHead != NULL) {
ExtState *state;
ExtState *stateNext;
// Free all states structures.
for (state = stateHead; state != NULL; state = stateNext) {
stateNext = state->next;
FreeState(state, removeCmds, 1);
}
stateHead = NULL;
}
Tcl_MutexUnlock(&stateListMutex);
Tcl_MutexFinalize(&stateListMutex);
#ifdef TCL_MEM_DEBUG
Tcl_DumpActiveMemory("MemDump.txt");
#endif
}
/*++
ExitHandler
Cleans up library on exit, frees all state structures
for every interpreter this extension was loaded in.
Arguments:
dummy - Not used.
Return Value:
None.
--*/
static void
ExitHandler(
ClientData dummy
)
{
Tcl_MutexLock(&initMutex);
#ifdef _WINDOWS
if (winProcs.module != NULL) {
FreeLibrary(winProcs.module);
}
ZeroMemory(&winProcs, sizeof(WinProcs));
#endif // _WINDOWS
initialised = 0;
Tcl_MutexUnlock(&initMutex);
Tcl_MutexLock(&stateMutex);
if (stateListHead != NULL) {
StateList *stateListPtr;
StateList *nextStateListPtr;
// Free all states structures.
for (stateListPtr = stateListHead; stateListPtr != NULL; stateListPtr = nextStateListPtr) {
nextStateListPtr = stateListPtr->next;
FreeState(stateListPtr->state);
ckfree((char *)stateListPtr);
}
stateListHead = NULL;
}
Tcl_MutexUnlock(&stateMutex);
#ifdef TCL_MEM_DEBUG
Tcl_DumpActiveMemory("MemDump.txt");
#endif
}
/* ARGSUSED */
static int
MemoryCmd(
ClientData clientData,
Tcl_Interp *interp,
int argc,
const char *argv[])
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option [args..]\"", NULL);
return TCL_ERROR;
}
if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_AppendResult(interp, "error accessing ", argv[2], NULL);
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"break_on_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(argv[1],"init") == 0) {
if (argc != 3) {
goto bad_suboption;
}
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],
" onexit file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName,fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(argv[1],"tag") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" tag string\"", NULL);
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree((char *) curTagPtr);
}
len = strlen(argv[2]);
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, argv[2], len + 1);
return TCL_OK;
}
if (strcmp(argv[1],"trace") == 0) {
if (argc != 3) {
goto bad_suboption;
}
alloc_tracing = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"validate") == 0) {
if (argc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be active, break_on_malloc, info, init, objs, onexit, "
"tag, trace, trace_on_at_malloc, or validate", NULL);
return TCL_ERROR;
argError:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " count\"", NULL);
return TCL_ERROR;
bad_suboption:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " on|off\"", NULL);
return TCL_ERROR;
}
