diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCkalloc.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCkalloc.c Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,1258 @@ +/* + * 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. + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. + * + * 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.19 2003/01/19 07:21:18 hobbs 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. */ +}; + +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__) +static struct mem_header *allocHead = NULL; /* List of allocated structures */ +#else +typedef struct mem_header (*memHeaderPtr); +#define allocHead (*(memHeaderPtr*)get_allocHead()) +#endif + +#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. + * + *---------------------------------------------------------------------- + */ +EXPORT_C 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. + *---------------------------------------------------------------------- + */ +EXPORT_C 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__. + * + *---------------------------------------------------------------------- + */ +EXPORT_C 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__. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C 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. + * + *-------------------------------------------------------------------- + */ +EXPORT_C 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 + +EXPORT_C 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); +} + +EXPORT_C void +Tcl_Free(ptr) + char *ptr; +{ + Tcl_DbCkfree(ptr, "unknown", 0); +} + +EXPORT_C 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C 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; +} + +EXPORT_C 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C char * +Tcl_AttemptAlloc (size) + unsigned int size; +{ + char *result; + + result = TclpAlloc(size); + return result; +} + +EXPORT_C 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C 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; +} + +EXPORT_C 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C char * +Tcl_AttemptRealloc(ptr, size) + char *ptr; + unsigned int size; +{ + char *result; + + result = TclpRealloc(ptr, size); + return result; +} + +EXPORT_C 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_Free (ptr) + char *ptr; +{ + TclpFree(ptr); +} + +EXPORT_C 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 */ +EXPORT_C void +Tcl_InitMemory(interp) + Tcl_Interp *interp; +{ +} + +EXPORT_C int +Tcl_DumpActiveMemory(fileName) + CONST char *fileName; +{ + return TCL_OK; +} + +EXPORT_C void +Tcl_ValidateAllMemory(file, line) + CONST char *file; + int line; +{ +} + +EXPORT_C 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 +}