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;
result = (char *) TclpAlloc(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;
}
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 *
TclpRealloc(
char *ptr,
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
void *newPtr;
size_t size, min;
int bucket;
if (ptr == NULL) {
return TclpAlloc(reqSize);
}
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
* If the block is not a system block and fits in place, simply return the
* existing pointer. Otherwise, if the block is a system block and the new
* size would also require a system block, call realloc() directly.
*/
blockPtr = Ptr2Block(ptr);
size = reqSize + sizeof(Block);
#if RCHECK
++size;
#endif
bucket = blockPtr->sourceBucket;
if (bucket != NBUCKETS) {
if (bucket > 0) {
min = bucketInfo[bucket-1].blockSize;
} else {
min = 0;
}
if (size > min && size <= bucketInfo[bucket].blockSize) {
cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
cachePtr->buckets[bucket].totalAssigned += reqSize;
return Block2Ptr(blockPtr, bucket, reqSize);
}
} else if (size > MAXALLOC) {
cachePtr->totalAssigned -= blockPtr->blockReqSize;
cachePtr->totalAssigned += reqSize;
blockPtr = realloc(blockPtr, size);
if (blockPtr == NULL) {
return NULL;
}
return Block2Ptr(blockPtr, NBUCKETS, reqSize);
}
/*
* Finally, perform an expensive malloc/copy/free.
*/
newPtr = TclpAlloc(reqSize);
if (newPtr != NULL) {
if (reqSize > blockPtr->blockReqSize) {
reqSize = blockPtr->blockReqSize;
}
memcpy(newPtr, ptr, reqSize);
TclpFree(ptr);
}
return newPtr;
}
/* ARGSUSED */
static int
MemoryCmd(
ClientData clientData,
Tcl_Interp *interp,
int argc,
const char *argv[])
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option [args..]\"", NULL);
return TCL_ERROR;
}
if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_AppendResult(interp, "error accessing ", argv[2], NULL);
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"break_on_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(argv[1],"init") == 0) {
if (argc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"objs") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" objs file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_AppendResult(interp, "cannot open output file", NULL);
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(argv[1],"onexit") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" onexit file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName,fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(argv[1],"tag") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" tag string\"", NULL);
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree((char *) curTagPtr);
}
len = strlen(argv[2]);
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, argv[2], len + 1);
return TCL_OK;
}
if (strcmp(argv[1],"trace") == 0) {
if (argc != 3) {
goto bad_suboption;
}
alloc_tracing = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"validate") == 0) {
if (argc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be active, break_on_malloc, info, init, objs, onexit, "
"tag, trace, trace_on_at_malloc, or validate", NULL);
return TCL_ERROR;
argError:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " count\"", NULL);
return TCL_ERROR;
bad_suboption:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " on|off\"", NULL);
return TCL_ERROR;
}
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((unsigned)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",
(long unsigned int) 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 *
TclpRealloc(
char *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
unsigned long maxSize;
if (oldPtr == NULL) {
return TclpAlloc(numBytes);
}
Tcl_MutexLock(allocMutexPtr);
overPtr = (union overhead *)((caddr_t)oldPtr - sizeof (union overhead));
ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */
ASSERT(overPtr->overMagic1 == MAGIC);
if (overPtr->overMagic0 != MAGIC || overPtr->overMagic1 != MAGIC) {
Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
i = overPtr->bucketIndex;
/*
* If the block isn't in a bin, just realloc it.
*/
if (i == 0xff) {
struct block *prevPtr, *nextPtr;
bigBlockPtr = (struct block *) overPtr - 1;
prevPtr = bigBlockPtr->prevPtr;
nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
sizeof(struct block) + OVERHEAD + numBytes);
if (bigBlockPtr == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
if (prevPtr->nextPtr != bigBlockPtr) {
/*
* If the block has moved, splice the new block into the list
* where the old block used to be.
*/
prevPtr->nextPtr = bigBlockPtr;
nextPtr->prevPtr = bigBlockPtr;
}
overPtr = (union overhead *) (bigBlockPtr + 1);
#ifdef MSTATS
numMallocs[NBUCKETS]++;
#endif
#ifdef RCHECK
/*
* Record allocated size of block and update magic number bounds.
*/
overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
BLOCK_END(overPtr) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (char *)(overPtr+1);
}
maxSize = 1 << (i+3);
expensive = 0;
if (numBytes+OVERHEAD > maxSize) {
expensive = 1;
} else if (i>0 && numBytes+OVERHEAD < maxSize/2) {
expensive = 1;
}
if (expensive) {
void *newPtr;
Tcl_MutexUnlock(allocMutexPtr);
newPtr = TclpAlloc(numBytes);
if (newPtr == NULL) {
return NULL;
}
maxSize -= OVERHEAD;
if (maxSize < numBytes) {
numBytes = maxSize;
}
memcpy(newPtr, oldPtr, (size_t) numBytes);
TclpFree(oldPtr);
return newPtr;
}
/*
* Ok, we don't have to copy, it fits as-is
*/
#ifdef RCHECK
overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
BLOCK_END(overPtr) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return(oldPtr);
}