1341 lines
32 KiB
C
1341 lines
32 KiB
C
/*
|
||
* 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
|
||
*/
|
||
|
||
#include "tclInt.h"
|
||
|
||
#define FALSE 0
|
||
#define TRUE 1
|
||
|
||
#undef Tcl_Alloc
|
||
#undef Tcl_Free
|
||
#undef Tcl_Realloc
|
||
#undef Tcl_AttemptAlloc
|
||
#undef Tcl_AttemptRealloc
|
||
|
||
#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[1]; /* 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) ((TclOffset(MemTag, string) + 1) + bytesInString))
|
||
|
||
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 \
|
||
((size_t) (&((struct mem_header *) 0)->body))
|
||
|
||
static int total_mallocs = 0;
|
||
static int total_frees = 0;
|
||
static size_t current_bytes_malloced = 0;
|
||
static size_t 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(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, const char *argv[]);
|
||
static int MemoryCmd(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, const char *argv[]);
|
||
static void ValidateMemory(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(void)
|
||
{
|
||
if (!ckallocInit) {
|
||
ckallocInit = 1;
|
||
ckallocMutexPtr = Tcl_GetAllocMutex();
|
||
#ifndef TCL_THREADS
|
||
/* Silence compiler warning */
|
||
(void)ckallocMutexPtr;
|
||
#endif
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclDumpMemoryInfo --
|
||
*
|
||
* Display the global memory management statistics.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclDumpMemoryInfo(
|
||
ClientData clientData,
|
||
int flags)
|
||
{
|
||
char buf[1024];
|
||
|
||
if (clientData == NULL) {
|
||
return 0;
|
||
}
|
||
sprintf(buf,
|
||
"total mallocs %10d\n"
|
||
"total frees %10d\n"
|
||
"current packets allocated %10d\n"
|
||
"current bytes allocated %10lu\n"
|
||
"maximum packets allocated %10d\n"
|
||
"maximum bytes allocated %10lu\n",
|
||
total_mallocs,
|
||
total_frees,
|
||
current_malloc_packets,
|
||
(unsigned long)current_bytes_malloced,
|
||
maximum_malloc_packets,
|
||
(unsigned long)maximum_bytes_malloced);
|
||
if (flags == 0) {
|
||
fprintf((FILE *)clientData, "%s", buf);
|
||
} else {
|
||
/* Assume objPtr to append to */
|
||
Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1);
|
||
}
|
||
return 1;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
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;
|
||
size_t 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", (int)idx, byte,
|
||
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
|
||
}
|
||
}
|
||
if (guard_failed) {
|
||
TclDumpMemoryInfo((ClientData) stderr, 0);
|
||
fprintf(stderr, "low guard failed at %lx, %s %d\n",
|
||
(unsigned long)(size_t)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);
|
||
Tcl_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", (int)idx, byte,
|
||
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
|
||
}
|
||
}
|
||
|
||
if (guard_failed) {
|
||
TclDumpMemoryInfo((ClientData) stderr, 0);
|
||
fprintf(stderr, "high guard failed at %lx, %s %d\n",
|
||
(unsigned long)(size_t)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);
|
||
Tcl_Panic("Memory validation failure");
|
||
}
|
||
|
||
if (nukeGuards) {
|
||
memset(memHeaderP->low_guard, 0, LOW_GUARD_SIZE);
|
||
memset(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(
|
||
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(
|
||
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",
|
||
(unsigned long)(size_t)address,
|
||
(unsigned long)(size_t)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(
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
struct mem_header *result = NULL;
|
||
|
||
if (validate_memory) {
|
||
Tcl_ValidateAllMemory(file, line);
|
||
}
|
||
|
||
/* Don't let size argument to TclpAlloc overflow */
|
||
if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) {
|
||
result = (struct mem_header *) TclpAlloc(size +
|
||
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
|
||
}
|
||
if (result == NULL) {
|
||
fflush(stdout);
|
||
TclDumpMemoryInfo((ClientData) stderr, 0);
|
||
Tcl_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(result, GUARD_VALUE,
|
||
size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
|
||
} else {
|
||
memset(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",
|
||
(unsigned long)(size_t)result->body, size, file, line);
|
||
}
|
||
|
||
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
|
||
break_on_malloc = 0;
|
||
(void) fflush(stdout);
|
||
Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
|
||
}
|
||
|
||
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(
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
struct mem_header *result = NULL;
|
||
|
||
if (validate_memory) {
|
||
Tcl_ValidateAllMemory(file, line);
|
||
}
|
||
|
||
/* Don't let size argument to TclpAlloc overflow */
|
||
if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
|
||
result = (struct mem_header *) TclpAlloc(size +
|
||
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
|
||
}
|
||
if (result == NULL) {
|
||
fflush(stdout);
|
||
TclDumpMemoryInfo((ClientData) stderr, 0);
|
||
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(result, GUARD_VALUE,
|
||
size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
|
||
} else {
|
||
memset(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",
|
||
(unsigned long)(size_t)result->body, size, file, line);
|
||
}
|
||
|
||
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
|
||
break_on_malloc = 0;
|
||
(void) fflush(stdout);
|
||
Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
|
||
}
|
||
|
||
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 Tcl_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__.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_DbCkfree(
|
||
char *ptr,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
struct mem_header *memp;
|
||
|
||
if (ptr == NULL) {
|
||
return;
|
||
}
|
||
|
||
/*
|
||
* 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 *) (((size_t) ptr) - BODY_OFFSET);
|
||
|
||
if (alloc_tracing) {
|
||
fprintf(stderr, "ckfree %lx %ld %s %d\n",
|
||
(unsigned long)(size_t)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(ptr, GUARD_VALUE, 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);
|
||
}
|
||
|
||
/*
|
||
*--------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
char *ptr,
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
char *newPtr;
|
||
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 *) (((size_t) ptr) - BODY_OFFSET);
|
||
|
||
copySize = size;
|
||
if (copySize > (unsigned int) memp->length) {
|
||
copySize = memp->length;
|
||
}
|
||
newPtr = Tcl_DbCkalloc(size, file, line);
|
||
memcpy(newPtr, ptr, copySize);
|
||
Tcl_DbCkfree(ptr, file, line);
|
||
return newPtr;
|
||
}
|
||
|
||
char *
|
||
Tcl_AttemptDbCkrealloc(
|
||
char *ptr,
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
char *newPtr;
|
||
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 *) (((size_t) ptr) - BODY_OFFSET);
|
||
|
||
copySize = size;
|
||
if (copySize > (unsigned int) memp->length) {
|
||
copySize = memp->length;
|
||
}
|
||
newPtr = Tcl_AttemptDbCkalloc(size, file, line);
|
||
if (newPtr == NULL) {
|
||
return NULL;
|
||
}
|
||
memcpy(newPtr, ptr, copySize);
|
||
Tcl_DbCkfree(ptr, file, line);
|
||
return newPtr;
|
||
}
|
||
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
char *
|
||
Tcl_Alloc(
|
||
unsigned int size)
|
||
{
|
||
return Tcl_DbCkalloc(size, "unknown", 0);
|
||
}
|
||
|
||
char *
|
||
Tcl_AttemptAlloc(
|
||
unsigned int size)
|
||
{
|
||
return Tcl_AttemptDbCkalloc(size, "unknown", 0);
|
||
}
|
||
|
||
void
|
||
Tcl_Free(
|
||
char *ptr)
|
||
{
|
||
Tcl_DbCkfree(ptr, "unknown", 0);
|
||
}
|
||
|
||
char *
|
||
Tcl_Realloc(
|
||
char *ptr,
|
||
unsigned int size)
|
||
{
|
||
return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
|
||
}
|
||
char *
|
||
Tcl_AttemptRealloc(
|
||
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 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_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s option [args..]\"", argv[0]));
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) {
|
||
if (argc != 3) {
|
||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s %s file\"",
|
||
argv[0], argv[1]));
|
||
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_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
|
||
argv[2], Tcl_PosixError(interp)));
|
||
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", (unsigned long)current_bytes_malloced,
|
||
"maximum packets allocated", maximum_malloc_packets,
|
||
"maximum bytes allocated", (unsigned long)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_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s objs file\"", argv[0]));
|
||
return TCL_ERROR;
|
||
}
|
||
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
|
||
if (fileName == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
fileP = fopen(fileName, "w");
|
||
if (fileP == NULL) {
|
||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"cannot open output file: %s",
|
||
Tcl_PosixError(interp)));
|
||
return TCL_ERROR;
|
||
}
|
||
TclDbDumpActiveObjects(fileP);
|
||
fclose(fileP);
|
||
Tcl_DStringFree(&buffer);
|
||
return TCL_OK;
|
||
}
|
||
if (strcmp(argv[1],"onexit") == 0) {
|
||
if (argc != 3) {
|
||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s onexit file\"", argv[0]));
|
||
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_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s tag string\"", argv[0]));
|
||
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_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"bad option \"%s\": should be active, break_on_malloc, info, "
|
||
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
|
||
argv[1]));
|
||
return TCL_ERROR;
|
||
|
||
argError:
|
||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
|
||
return TCL_ERROR;
|
||
|
||
bad_suboption:
|
||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
|
||
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 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_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"wrong # args: should be \"%s fileName\"", argv[0]));
|
||
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(
|
||
Tcl_Interp *interp) /* Interpreter in which commands should be
|
||
* added */
|
||
{
|
||
TclInitDbCkalloc();
|
||
Tcl_CreateCommand(interp, "memory", MemoryCmd, NULL, NULL);
|
||
Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, NULL, 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(
|
||
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) {
|
||
Tcl_Panic("unable to alloc %u bytes", size);
|
||
}
|
||
return result;
|
||
}
|
||
|
||
char *
|
||
Tcl_DbCkalloc(
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
char *result;
|
||
|
||
result = (char *) TclpAlloc(size);
|
||
|
||
if ((result == NULL) && size) {
|
||
fflush(stdout);
|
||
Tcl_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(
|
||
unsigned int size)
|
||
{
|
||
char *result;
|
||
|
||
result = TclpAlloc(size);
|
||
return result;
|
||
}
|
||
|
||
char *
|
||
Tcl_AttemptDbCkalloc(
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
char *result;
|
||
(void)file;
|
||
(void)line;
|
||
|
||
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(
|
||
char *ptr,
|
||
unsigned int size)
|
||
{
|
||
char *result;
|
||
|
||
result = TclpRealloc(ptr, size);
|
||
|
||
if ((result == NULL) && size) {
|
||
Tcl_Panic("unable to realloc %u bytes", size);
|
||
}
|
||
return result;
|
||
}
|
||
|
||
char *
|
||
Tcl_DbCkrealloc(
|
||
char *ptr,
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
char *result;
|
||
|
||
result = (char *) TclpRealloc(ptr, size);
|
||
|
||
if ((result == NULL) && size) {
|
||
fflush(stdout);
|
||
Tcl_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(
|
||
char *ptr,
|
||
unsigned int size)
|
||
{
|
||
char *result;
|
||
|
||
result = TclpRealloc(ptr, size);
|
||
return result;
|
||
}
|
||
|
||
char *
|
||
Tcl_AttemptDbCkrealloc(
|
||
char *ptr,
|
||
unsigned int size,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
char *result;
|
||
(void)file;
|
||
(void)line;
|
||
|
||
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(
|
||
char *ptr)
|
||
{
|
||
TclpFree(ptr);
|
||
}
|
||
|
||
void
|
||
Tcl_DbCkfree(
|
||
char *ptr,
|
||
const char *file,
|
||
int line)
|
||
{
|
||
(void)file;
|
||
(void)line;
|
||
TclpFree(ptr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_InitMemory --
|
||
*
|
||
* Dummy initialization for memory command, which is only available if
|
||
* TCL_MEM_DEBUG is on.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
/* ARGSUSED */
|
||
void
|
||
Tcl_InitMemory(
|
||
Tcl_Interp *interp)
|
||
{
|
||
(void)interp;
|
||
}
|
||
|
||
int
|
||
Tcl_DumpActiveMemory(
|
||
const char *fileName)
|
||
{
|
||
(void)fileName;
|
||
return TCL_OK;
|
||
}
|
||
|
||
void
|
||
Tcl_ValidateAllMemory(
|
||
const char *file,
|
||
int line)
|
||
{
|
||
(void)file;
|
||
(void)line;
|
||
}
|
||
|
||
int
|
||
TclDumpMemoryInfo(
|
||
ClientData clientData,
|
||
int flags)
|
||
{
|
||
(void)clientData;
|
||
(void)flags;
|
||
return 1;
|
||
}
|
||
|
||
#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(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 defined(USE_TCLALLOC) && USE_TCLALLOC
|
||
TclFinalizeAllocSubsystem();
|
||
#endif
|
||
}
|
||
|
||
/*
|
||
* Local Variables:
|
||
* mode: c
|
||
* c-basic-offset: 4
|
||
* fill-column: 78
|
||
* tab-width: 8
|
||
* indent-tabs-mode: nil
|
||
* End:
|
||
*/
|