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; }