/* * tclCkalloc.c -- * * Interface to malloc and free that provides support for debugging problems * involving overwritten, double freeing memory and loss of memory. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans * * RCS: @(#) $Id: tclCkalloc.c,v 1.1.1.1 2007/07/10 15:04:23 duncan Exp $ */ #include "tclInt.h" #include "tclPort.h" #define FALSE 0 #define TRUE 1 #ifdef TCL_MEM_DEBUG /* * One of the following structures is allocated each time the * "memory tag" command is invoked, to hold the current tag. */ typedef struct MemTag { int refCount; /* Number of mem_headers referencing * this tag. */ char string[4]; /* Actual size of string will be as * large as needed for actual tag. This * must be the last field in the structure. */ } MemTag; #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers * (set by "memory tag" command). */ /* * One of the following structures is allocated just before each * dynamically allocated chunk of memory, both to record information * about the chunk and to help detect chunk under-runs. */ #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ CONST char *file; long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ char body[1]; /* First byte of client's space. Actual * size of this field will be larger than * one. */ }; static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define GUARD_VALUE 0141 /* * The following macro determines the amount of guard space *above* each * chunk of memory. */ #define HIGH_GUARD_SIZE 8 /* * The following macro computes the offset of the "body" field within * mem_header. It is used to get back to the header pointer from the * body pointer that's used by clients. */ #define BODY_OFFSET \ ((unsigned long) (&((struct mem_header *) 0)->body)) static int total_mallocs = 0; static int total_frees = 0; static int current_bytes_malloced = 0; static int maximum_bytes_malloced = 0; static int current_malloc_packets = 0; static int maximum_malloc_packets = 0; static int break_on_malloc = 0; static int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE static int validate_memory = TRUE; #else static int validate_memory = FALSE; #endif /* * The following variable indicates to TclFinalizeMemorySubsystem() * that it should dump out the state of memory before exiting. If the * value is non-NULL, it gives the name of the file in which to * dump memory usage information. */ char *tclMemDumpFileName = NULL; static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* * Mutex to serialize allocations. This is a low-level mutex that must * be explicitly initialized. This is necessary because the self * initializing mutexes use ckalloc... */ static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; /* * Prototypes for procedures defined in this file: */ static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, CONST char *argv[])); static int MemoryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, CONST char **argv)); static void ValidateMemory _ANSI_ARGS_(( struct mem_header *memHeaderP, CONST char *file, int line, int nukeGuards)); /* *---------------------------------------------------------------------- * * TclInitDbCkalloc -- * Initialize the locks used by the allocator. * This is only appropriate to call in a single threaded environment, * such as during TclInitSubsystems. * *---------------------------------------------------------------------- */ void TclInitDbCkalloc() { if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); } } /* *---------------------------------------------------------------------- * * TclDumpMemoryInfo -- * Display the global memory management statistics. * *---------------------------------------------------------------------- */ void TclDumpMemoryInfo(outFile) FILE *outFile; { fprintf(outFile,"total mallocs %10d\n", total_mallocs); fprintf(outFile,"total frees %10d\n", total_frees); fprintf(outFile,"current packets allocated %10d\n", current_malloc_packets); fprintf(outFile,"current bytes allocated %10d\n", current_bytes_malloced); fprintf(outFile,"maximum packets allocated %10d\n", maximum_malloc_packets); fprintf(outFile,"maximum bytes allocated %10d\n", maximum_bytes_malloced); } /* *---------------------------------------------------------------------- * * ValidateMemory -- * * Validate memory guard zones for a particular chunk of allocated * memory. * * Results: * None. * * Side effects: * Prints validation information about the allocated memory to stderr. * *---------------------------------------------------------------------- */ static void ValidateMemory(memHeaderP, file, line, nukeGuards) struct mem_header *memHeaderP; /* Memory chunk to validate */ CONST char *file; /* File containing the call to * Tcl_ValidateAllMemory */ int line; /* Line number of call to * Tcl_ValidateAllMemory */ int nukeGuards; /* If non-zero, indicates that the * memory guards are to be reset to 0 * after they have been printed */ { unsigned char *hiPtr; int idx; int guard_failed = FALSE; int byte; for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { byte = *(memHeaderP->low_guard + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush(stdout); byte &= 0xff; fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { TclDumpMemoryInfo (stderr); fprintf(stderr, "low guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); panic ("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { byte = *(hiPtr + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush (stdout); byte &= 0xff; fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { TclDumpMemoryInfo (stderr); fprintf(stderr, "high guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); panic("Memory validation failure"); } if (nukeGuards) { memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE); } } /* *---------------------------------------------------------------------- * * Tcl_ValidateAllMemory -- * * Validate memory guard regions for all allocated memory. * * Results: * None. * * Side effects: * Displays memory validation information to stderr. * *---------------------------------------------------------------------- */ void Tcl_ValidateAllMemory (file, line) CONST char *file; /* File from which Tcl_ValidateAllMemory was called */ int line; /* Line number of call to Tcl_ValidateAllMemory */ { struct mem_header *memScanP; if (!ckallocInit) { TclInitDbCkalloc(); } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { ValidateMemory(memScanP, file, line, FALSE); } Tcl_MutexUnlock(ckallocMutexPtr); } /* *---------------------------------------------------------------------- * * Tcl_DumpActiveMemory -- * * Displays all allocated memory to a file; if no filename is given, * information will be written to stderr. * * Results: * Return TCL_ERROR if an error accessing the file occurs, `errno' * will have the file error number left in it. *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory (fileName) CONST char *fileName; /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; char *address; if (fileName == NULL) { fileP = stderr; } else { fileP = fopen(fileName, "w"); if (fileP == NULL) { return TCL_ERROR; } } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body [0]; fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", (long unsigned int) address, (long unsigned int) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } Tcl_MutexUnlock(ckallocMutexPtr); if (fileP != stderr) { fclose (fileP); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_DbCkalloc - debugging ckalloc * * Allocate the requested amount of space plus some extra for * guard bands at both ends of the request, plus a size, panicing * if there isn't enough space, then write in the guard bands * and return the address of the space in the middle that the * user asked for. * * The second and third arguments are file and line, these contain * the filename and line number corresponding to the caller. * These are sent by the ckalloc macro; it uses the preprocessor * autodefines __FILE__ and __LINE__. * *---------------------------------------------------------------------- */ char * Tcl_DbCkalloc(size, file, line) unsigned int size; CONST char *file; int line; { struct mem_header *result; if (validate_memory) Tcl_ValidateAllMemory (file, line); result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { fflush(stdout); TclDumpMemoryInfo(stderr); panic("unable to alloc %u bytes, %s line %d", size, file, line); } /* * Fill in guard zones and size. Also initialize the contents of * the block with bogus bytes to detect uses of initialized data. * Link into allocated list. */ if (init_malloced_bodies) { memset ((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } if (!ckallocInit) { TclInitDbCkalloc(); } Tcl_MutexLock(ckallocMutexPtr); result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { curTagPtr->refCount++; } result->file = file; result->line = line; result->flink = allocHead; result->blink = NULL; if (allocHead != NULL) allocHead->blink = result; allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); fprintf(stderr, "reached malloc trace enable point (%d)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) fprintf(stderr,"ckalloc %lx %u %s %d\n", (long unsigned int) result->body, size, file, line); if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); fprintf(stderr,"reached malloc break limit (%d)\n", total_mallocs); fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) maximum_malloc_packets = current_malloc_packets; current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) maximum_bytes_malloced = current_bytes_malloced; Tcl_MutexUnlock(ckallocMutexPtr); return result->body; } char * Tcl_AttemptDbCkalloc(size, file, line) unsigned int size; CONST char *file; int line; { struct mem_header *result; if (validate_memory) Tcl_ValidateAllMemory (file, line); result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { fflush(stdout); TclDumpMemoryInfo(stderr); return NULL; } /* * Fill in guard zones and size. Also initialize the contents of * the block with bogus bytes to detect uses of initialized data. * Link into allocated list. */ if (init_malloced_bodies) { memset ((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } if (!ckallocInit) { TclInitDbCkalloc(); } Tcl_MutexLock(ckallocMutexPtr); result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { curTagPtr->refCount++; } result->file = file; result->line = line; result->flink = allocHead; result->blink = NULL; if (allocHead != NULL) allocHead->blink = result; allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); fprintf(stderr, "reached malloc trace enable point (%d)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) fprintf(stderr,"ckalloc %lx %u %s %d\n", (long unsigned int) result->body, size, file, line); if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); fprintf(stderr,"reached malloc break limit (%d)\n", total_mallocs); fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) maximum_malloc_packets = current_malloc_packets; current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) maximum_bytes_malloced = current_bytes_malloced; Tcl_MutexUnlock(ckallocMutexPtr); return result->body; } /* *---------------------------------------------------------------------- * * Tcl_DbCkfree - debugging ckfree * * Verify that the low and high guards are intact, and if so * then free the buffer else panic. * * The guards are erased after being checked to catch duplicate * frees. * * The second and third arguments are file and line, these contain * the filename and line number corresponding to the caller. * These are sent by the ckfree macro; it uses the preprocessor * autodefines __FILE__ and __LINE__. * *---------------------------------------------------------------------- */ int Tcl_DbCkfree(ptr, file, line) char *ptr; CONST char *file; int line; { struct mem_header *memp; if (ptr == NULL) { return 0; } /* * The following cast is *very* tricky. Must convert the pointer * to an integer before doing arithmetic on it, because otherwise * the arithmetic will be done differently (and incorrectly) on * word-addressed machines such as Crays (will subtract only bytes, * even though BODY_OFFSET is in words on these machines). */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); if (alloc_tracing) { fprintf(stderr, "ckfree %lx %ld %s %d\n", (long unsigned int) memp->body, memp->length, file, line); } if (validate_memory) { Tcl_ValidateAllMemory(file, line); } Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); } total_frees++; current_malloc_packets--; current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { memp->tagPtr->refCount--; if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { TclpFree((char *) memp->tagPtr); } } /* * Delink from allocated list */ if (memp->flink != NULL) memp->flink->blink = memp->blink; if (memp->blink != NULL) memp->blink->flink = memp->flink; if (allocHead == memp) allocHead = memp->flink; TclpFree((char *) memp); Tcl_MutexUnlock(ckallocMutexPtr); return 0; } /* *-------------------------------------------------------------------- * * Tcl_DbCkrealloc - debugging ckrealloc * * Reallocate a chunk of memory by allocating a new one of the * right size, copying the old data to the new location, and then * freeing the old memory space, using all the memory checking * features of this package. * *-------------------------------------------------------------------- */ char * Tcl_DbCkrealloc(ptr, size, file, line) char *ptr; unsigned int size; CONST char *file; int line; { char *new; unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { return Tcl_DbCkalloc(size, file, line); } /* * See comment from Tcl_DbCkfree before you change the following * line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { copySize = memp->length; } new = Tcl_DbCkalloc(size, file, line); memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); Tcl_DbCkfree(ptr, file, line); return new; } char * Tcl_AttemptDbCkrealloc(ptr, size, file, line) char *ptr; unsigned int size; CONST char *file; int line; { char *new; unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { return Tcl_AttemptDbCkalloc(size, file, line); } /* * See comment from Tcl_DbCkfree before you change the following * line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { copySize = memp->length; } new = Tcl_AttemptDbCkalloc(size, file, line); if (new == NULL) { return NULL; } memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); Tcl_DbCkfree(ptr, file, line); return new; } /* *---------------------------------------------------------------------- * * Tcl_Alloc, et al. -- * * These functions are defined in terms of the debugging versions * when TCL_MEM_DEBUG is set. * * Results: * Same as the debug versions. * * Side effects: * Same as the debug versions. * *---------------------------------------------------------------------- */ #undef Tcl_Alloc #undef Tcl_Free #undef Tcl_Realloc #undef Tcl_AttemptAlloc #undef Tcl_AttemptRealloc char * Tcl_Alloc(size) unsigned int size; { return Tcl_DbCkalloc(size, "unknown", 0); } char * Tcl_AttemptAlloc(size) unsigned int size; { return Tcl_AttemptDbCkalloc(size, "unknown", 0); } void Tcl_Free(ptr) char *ptr; { Tcl_DbCkfree(ptr, "unknown", 0); } char * Tcl_Realloc(ptr, size) char *ptr; unsigned int size; { return Tcl_DbCkrealloc(ptr, size, "unknown", 0); } char * Tcl_AttemptRealloc(ptr, size) char *ptr; unsigned int size; { return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); } /* *---------------------------------------------------------------------- * * MemoryCmd -- * Implements the Tcl "memory" command, which provides Tcl-level * control of Tcl memory debugging information. * memory active $file * memory break_on_malloc $count * memory info * memory init on|off * memory onexit $file * memory tag $string * memory trace on|off * memory trace_on_at_malloc $count * memory validate on|off * * Results: * Standard TCL results. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int MemoryCmd (clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; CONST char **argv; { CONST char *fileName; Tcl_DString buffer; int result; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option [args..]\"", (char *) 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\"", (char *) 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], (char *) 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) { char buf[400]; sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\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); Tcl_SetResult(interp, buf, TCL_VOLATILE); 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],"onexit") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " onexit file\"", (char *) 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\"", (char *) NULL); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { TclpFree((char *) curTagPtr); } curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); curTagPtr->refCount = 0; strcpy(curTagPtr->string, argv[2]); 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, onexit, ", "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; argError: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " count\"", (char *) NULL); return TCL_ERROR; bad_suboption: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " on|off\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * CheckmemCmd -- * * This is the command procedure for the "checkmem" command, which * causes the application to exit after printing information about * memory usage to the file passed to this command as its first * argument. * * Results: * Returns a standard Tcl completion code. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int CheckmemCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter for evaluation. */ int argc; /* Number of arguments. */ CONST char *argv[]; /* String values of arguments. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileName\"", (char *) NULL); return TCL_ERROR; } tclMemDumpFileName = dumpFile; strcpy(tclMemDumpFileName, argv[1]); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * * Create the "memory" and "checkmem" commands in the given * interpreter. * * Results: * None. * * Side effects: * New commands are added to the interpreter. * *---------------------------------------------------------------------- */ void Tcl_InitMemory(interp) Tcl_Interp *interp; /* Interpreter in which commands should be added */ { TclInitDbCkalloc(); Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); } #else /* TCL_MEM_DEBUG */ /* This is the !TCL_MEM_DEBUG case */ #undef Tcl_InitMemory #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory /* *---------------------------------------------------------------------- * * Tcl_Alloc -- * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_Alloc (size) unsigned int size; { char *result; result = TclpAlloc(size); /* * Most systems will not alloc(0), instead bumping it to one so * that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0) * by returning NULL, so we have to check that the NULL we get is * not in response to alloc(0). * * The ANSI spec actually says that systems either return NULL *or* * a special pointer on failure, but we only check for NULL */ if ((result == NULL) && size) { panic("unable to alloc %u bytes", size); } return result; } char * Tcl_DbCkalloc(size, file, line) unsigned int size; CONST char *file; int line; { char *result; result = (char *) TclpAlloc(size); if ((result == NULL) && size) { fflush(stdout); panic("unable to alloc %u bytes, %s line %d", size, file, line); } return result; } /* *---------------------------------------------------------------------- * * Tcl_AttemptAlloc -- * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not * check that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_AttemptAlloc (size) unsigned int size; { char *result; result = TclpAlloc(size); return result; } char * Tcl_AttemptDbCkalloc(size, file, line) unsigned int size; CONST char *file; int line; { char *result; result = (char *) TclpAlloc(size); return result; } /* *---------------------------------------------------------------------- * * Tcl_Realloc -- * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does * check that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_Realloc(ptr, size) char *ptr; unsigned int size; { char *result; result = TclpRealloc(ptr, size); if ((result == NULL) && size) { panic("unable to realloc %u bytes", size); } return result; } char * Tcl_DbCkrealloc(ptr, size, file, line) char *ptr; unsigned int size; CONST char *file; int line; { char *result; result = (char *) TclpRealloc(ptr, size); if ((result == NULL) && size) { fflush(stdout); panic("unable to realloc %u bytes, %s line %d", size, file, line); } return result; } /* *---------------------------------------------------------------------- * * Tcl_AttemptRealloc -- * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does * not check that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_AttemptRealloc(ptr, size) char *ptr; unsigned int size; { char *result; result = TclpRealloc(ptr, size); return result; } char * Tcl_AttemptDbCkrealloc(ptr, size, file, line) char *ptr; unsigned int size; CONST char *file; int line; { char *result; result = (char *) TclpRealloc(ptr, size); return result; } /* *---------------------------------------------------------------------- * * Tcl_Free -- * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here * rather in the macro to keep some modules from being compiled with * TCL_MEM_DEBUG enabled and some with it disabled. * *---------------------------------------------------------------------- */ void Tcl_Free (ptr) char *ptr; { TclpFree(ptr); } int Tcl_DbCkfree(ptr, file, line) char *ptr; CONST char *file; int line; { TclpFree(ptr); return 0; } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * Dummy initialization for memory command, which is only available * if TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- */ /* ARGSUSED */ void Tcl_InitMemory(interp) Tcl_Interp *interp; { } int Tcl_DumpActiveMemory(fileName) CONST char *fileName; { return TCL_OK; } void Tcl_ValidateAllMemory(file, line) CONST char *file; int line; { } void TclDumpMemoryInfo(outFile) FILE *outFile; { } #endif /* TCL_MEM_DEBUG */ /* *--------------------------------------------------------------------------- * * TclFinalizeMemorySubsystem -- * * This procedure is called to finalize all the structures that * are used by the memory allocator on a per-process basis. * * Results: * None. * * Side effects: * This subsystem is self-initializing, since memory can be * allocated before Tcl is formally initialized. After this call, * this subsystem has been reset to its initial state and is * usable again. * *--------------------------------------------------------------------------- */ void TclFinalizeMemorySubsystem() { #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 }