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