diff options
Diffstat (limited to 'generic/tclAlloc.c')
| -rw-r--r-- | generic/tclAlloc.c | 847 |
1 files changed, 270 insertions, 577 deletions
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index ae61e85..31bbb8b 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -1,155 +1,146 @@ /* * tclAlloc.c -- * - * This is a very fast storage allocator. It allocates blocks of a small - * number of different sizes, and keeps free lists of each size. Blocks - * that don't exactly fit are passed up to the next larger size. Blocks - * over a certain size are directly allocated from the system. + * This is the generic part of the Tcl allocator. It handles the + * freeObjLists and defines which main allocator will be used. * - * Copyright (c) 1983 Regents of the University of California. - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. + * Copyright (c) 2013 by Miguel Sofer. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/* - * Windows and Unix use an alternative allocator when building with threads - * that has significantly reduced lock contention. - */ - #include "tclInt.h" -#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) - -#if USE_TCLALLOC - -/* - * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait - * until Tcl uses config.h properly. - */ - -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) -typedef unsigned long caddr_t; -#endif +#include "tclAlloc.h" /* - * The overhead on a block is at least 8 bytes. When free, this space contains - * a pointer to the next free block, and the bottom two bits must be zero. - * When in use, the first byte is set to MAGIC, and the second byte is the - * size index. The remaining bytes are for alignment. If range checking is - * enabled then a second word holds the size of the requested block, less 1, - * rounded up to a multiple of sizeof(RMAGIC). The order of elements is - * critical: ov.magic must overlay the low order bits of ov.next, and ov.magic - * can not be a valid ov.next bit pattern. + * Parameters for the per-thread Tcl_Obj cache: + * - if >NOBJHIGH free objects, move some to the shared cache + * - if no objects are available, create NOBJALLOC of them */ -union overhead { - union overhead *next; /* when free */ - unsigned char padding[TCL_ALLOCALIGN]; /* align struct to TCL_ALLOCALIGN bytes */ - struct { - unsigned char magic0; /* magic number */ - unsigned char index; /* bucket # */ - unsigned char unused; /* unused */ - unsigned char magic1; /* other magic number */ -#ifndef NDEBUG - unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ - unsigned short unused2; /* padding to 8-byte align */ -#endif - } ovu; -#define overMagic0 ovu.magic0 -#define overMagic1 ovu.magic1 -#define bucketIndex ovu.index -#define rangeCheckMagic ovu.rmagic -#define realBlockSize ovu.size -}; - - -#define MAGIC 0xef /* magic # on accounting info */ -#define RMAGIC 0x5555 /* magic # on range info */ - -#ifndef NDEBUG -#define RSLOP sizeof(unsigned short) -#else -#define RSLOP 0 -#endif +#define NOBJHIGH 1200 +#define NOBJALLOC ((NOBJHIGH*2)/3) -#define OVERHEAD (sizeof(union overhead) + RSLOP) /* - * Macro to make it easier to refer to the end-of-block guard magic. + * The Tcl_Obj per-thread cache. */ -#define BLOCK_END(overPtr) \ - (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize)) - -/* - * nextf[i] is the pointer to the next free block of size 2^(i+3). The - * smallest allocatable block is MINBLOCK bytes. The overhead information - * precedes the data area returned to the user. - */ - -#define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) -#define NBUCKETS (13 - (MINBLOCK >> 4)) -#define MAXMALLOC (1<<(NBUCKETS+2)) -static union overhead *nextf[NBUCKETS]; +typedef struct Cache { + Tcl_Obj *firstObjPtr; /* List of free objects for thread */ + int numObjects; /* Number of objects for thread */ + void *allocCachePtr; +} Cache; + +static Cache sharedCache; +#define sharedPtr (&sharedCache) + +#if defined(TCL_THREADS) +static Tcl_Mutex *objLockPtr; + +static Cache * GetCache(void); +static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); + +#if defined(HAVE_FAST_TSD) +static __thread Cache *tcachePtr; + +# define GETCACHE(cachePtr) \ + do { \ + if (!tcachePtr) { \ + tcachePtr = GetCache(); \ + } \ + (cachePtr) = tcachePtr; \ + } while (0) + +#else /* THREADS, not HAVE_FAST_TSD */ +# define GETCACHE(cachePtr) \ + do { \ + (cachePtr) = TclpGetAllocCache(); \ + if ((cachePtr) == NULL) { \ + (cachePtr) = GetCache(); \ + } \ + } while (0) +#endif /* FAST TSD */ + +#else /* NOT THREADS */ +#define GETCACHE(cachePtr) \ + (cachePtr) = (&sharedCache) +#endif /* THREADS */ + /* - * The following structure is used to keep track of all system memory - * currently owned by Tcl. When finalizing, all this memory will be returned - * to the system. + *---------------------------------------------------------------------- + * + * GetCache --- + * + * Gets per-thread memory cache, allocating it if necessary. + * + * Results: + * Pointer to cache. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ -struct block { - struct block *nextPtr; /* Linked list. */ - struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte - * alignment for suballocated blocks. */ -}; +#if defined(TCL_THREADS) +static Cache * +GetCache(void) +{ + Cache *cachePtr; -static struct block *blockList; /* Tracks the suballocated blocks. */ -static struct block bigBlocks={ /* Big blocks aren't suballocated. */ - &bigBlocks, &bigBlocks -}; + /* + * Get this thread's cache, allocating if necessary. + */ + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = calloc(1, sizeof(Cache)); + if (cachePtr == NULL) { + Tcl_Panic("alloc: could not allocate new cache"); + } + cachePtr->allocCachePtr= NULL; + TclpSetAllocCache(cachePtr); + } + return cachePtr; +} +#endif + /* - * The allocator is protected by a special mutex that must be explicitly - * initialized. Futhermore, because Tcl_Alloc may be used before anything else - * in Tcl, we make this module self-initializing after all with the allocInit - * variable. + * TclSetSharedAllocCache, TclSetAllocCache, TclGetAllocCache + * + * These are utility functions for the loadable allocator. */ -#ifdef TCL_THREADS -static Tcl_Mutex *allocMutexPtr; -#endif -static int allocInit = 0; - -#ifdef MSTATS +void +TclSetSharedAllocCache( + void *allocCachePtr) +{ + sharedPtr->allocCachePtr = allocCachePtr; +} -/* - * numMallocs[i] is the difference between the number of mallocs and frees for - * a given block size. - */ +void +TclSetAllocCache( + void *allocCachePtr) +{ + Cache *cachePtr; -static unsigned int numMallocs[NBUCKETS+1]; -#endif + GETCACHE(cachePtr); + cachePtr->allocCachePtr = allocCachePtr; +} -#if !defined(NDEBUG) -#define ASSERT(p) if (!(p)) Tcl_Panic(# p) -#define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) -#else -#define ASSERT(p) -#define RANGE_ASSERT(p) -#endif +void * +TclGetAllocCache(void) +{ + Cache *cachePtr; -/* - * Prototypes for functions used only in this file. - */ + GETCACHE(cachePtr); + return cachePtr->allocCachePtr; +} -static void MoreCore(int bucket); - + /* *------------------------------------------------------------------------- * @@ -161,7 +152,8 @@ static void MoreCore(int bucket); * None. * * Side effects: - * Initialize the mutex used to serialize allocations. + * Initialize the mutex used to serialize obj allocations. + * Call the allocator-specific initialization. * *------------------------------------------------------------------------- */ @@ -169,76 +161,67 @@ static void MoreCore(int bucket); void TclInitAlloc(void) { - if (!allocInit) { - allocInit = 1; -#ifdef TCL_THREADS - allocMutexPtr = Tcl_GetAllocMutex(); + /* + * Set the params for the correct allocator + */ + +#if defined(TCL_THREADS) + Tcl_Mutex *initLockPtr; + + TCL_THREADED = 1; + initLockPtr = Tcl_GetAllocMutex(); + Tcl_MutexLock(initLockPtr); + objLockPtr = TclpNewAllocMutex(); + TclXpInitAlloc(); + Tcl_MutexUnlock(initLockPtr); +#else + TCL_THREADED = 0; + TclXpInitAlloc(); +#endif /* THREADS */ + +#ifdef PURIFY + TCL_PURIFY = 1; +#else + TCL_PURIFY = (getenv("TCL_PURIFY") != NULL); #endif - } } /* - *------------------------------------------------------------------------- - * - * TclFinalizeAllocSubsystem -- + *---------------------------------------------------------------------- * - * Release all resources being used by this subsystem, including - * aggressively freeing all memory allocated by TclpAlloc() that has not - * yet been released with TclpFree(). + * TclFinalizeAlloc -- * - * After this function is called, all memory allocated with TclpAlloc() - * should be considered unusable. + * This procedure is used to destroy all private resources used in this + * file. * * 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. + * Call the allocator-specific finalization. * - *------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ void -TclFinalizeAllocSubsystem(void) +TclFinalizeAlloc(void) { - unsigned int i; - struct block *blockPtr, *nextPtr; - - Tcl_MutexLock(allocMutexPtr); - for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) { - nextPtr = blockPtr->nextPtr; - TclpSysFree(blockPtr); - } - blockList = NULL; +#if defined(TCL_THREADS) - for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) { - nextPtr = blockPtr->nextPtr; - TclpSysFree(blockPtr); - blockPtr = nextPtr; - } - bigBlocks.nextPtr = &bigBlocks; - bigBlocks.prevPtr = &bigBlocks; + TclpFreeAllocMutex(objLockPtr); + objLockPtr = NULL; - for (i=0 ; i<NBUCKETS ; i++) { - nextf[i] = NULL; -#ifdef MSTATS - numMallocs[i] = 0; -#endif - } -#ifdef MSTATS - numMallocs[i] = 0; + TclpFreeAllocCache(NULL); #endif - Tcl_MutexUnlock(allocMutexPtr); + TclXpFinalizeAlloc(); } /* *---------------------------------------------------------------------- * - * TclpAlloc -- + * TclFreeAllocCache -- * - * Allocate more memory. + * Flush and delete a cache, removing from list of caches. * * Results: * None. @@ -249,387 +232,174 @@ TclFinalizeAllocSubsystem(void) *---------------------------------------------------------------------- */ -char * -TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ +#if defined(TCL_THREADS) +void +TclFreeAllocCache( + void *arg) { - register union overhead *overPtr; - register long bucket; - register unsigned amount; - struct block *bigBlockPtr = NULL; - - if (!allocInit) { - /* - * We have to make the "self initializing" because Tcl_Alloc may be - * used before any other part of Tcl. E.g., see main() for tclsh! - */ - - TclInitAlloc(); - } - Tcl_MutexLock(allocMutexPtr); - + Cache *cachePtr = arg; + /* - * First the simple case: we simple allocate big blocks directly. + * Flush objs. */ - if (numBytes >= MAXMALLOC - OVERHEAD) { - if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + OVERHEAD + numBytes), 0); - } - if (bigBlockPtr == NULL) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - bigBlockPtr->nextPtr = bigBlocks.nextPtr; - bigBlocks.nextPtr = bigBlockPtr; - bigBlockPtr->prevPtr = &bigBlocks; - bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; - - overPtr = (union overhead *) (bigBlockPtr + 1); - overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = 0xff; -#ifdef MSTATS - numMallocs[NBUCKETS]++; -#endif - -#ifndef NDEBUG - /* - * Record allocated size of block and bound space with magic numbers. - */ - - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - overPtr->rangeCheckMagic = RMAGIC; - BLOCK_END(overPtr) = RMAGIC; -#endif - - Tcl_MutexUnlock(allocMutexPtr); - return (void *)(overPtr+1); + if (cachePtr->numObjects > 0) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); + Tcl_MutexUnlock(objLockPtr); } /* - * Convert amount of memory requested into closest block size stored in - * hash buckets which satisfies request. Account for space used per block - * for accounting. + * Flush the external allocator cache */ - amount = MINBLOCK; /* size of first bucket */ - bucket = MINBLOCK >> 4; - - while (numBytes + OVERHEAD > amount) { - amount <<= 1; - if (amount == 0) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - bucket++; - } - ASSERT(bucket < NBUCKETS); - - /* - * If nothing in hash bucket right now, request more memory from the - * system. - */ - - if ((overPtr = nextf[bucket]) == NULL) { - MoreCore(bucket); - if ((overPtr = nextf[bucket]) == NULL) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - } - - /* - * Remove from linked list - */ - - nextf[bucket] = overPtr->next; - overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = (unsigned char) bucket; - -#ifdef MSTATS - numMallocs[bucket]++; -#endif - -#ifndef NDEBUG - /* - * Record allocated size of block and bound space with magic numbers. - */ - - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - overPtr->rangeCheckMagic = RMAGIC; - BLOCK_END(overPtr) = RMAGIC; -#endif - - Tcl_MutexUnlock(allocMutexPtr); - return ((char *)(overPtr + 1)); + TclXpFreeAllocCache(cachePtr->allocCachePtr); } +#endif /* *---------------------------------------------------------------------- * - * MoreCore -- - * - * Allocate more memory to the indicated bucket. + * TclSmallAlloc -- * - * Assumes Mutex is already held. + * Allocate a Tcl_Obj sized block from the per-thread cache. * * Results: - * None. + * Pointer to uninitialized memory. * * Side effects: - * Attempts to get more memory from the system. + * May move blocks from shared cached or allocate new blocks if + * list is empty. * *---------------------------------------------------------------------- */ -static void -MoreCore( - int bucket) /* What bucket to allocat to. */ +void * +TclSmallAlloc(void) { - register union overhead *overPtr; - register long size; /* size of desired block */ - long amount; /* amount to allocate */ - int numBlocks; /* how many blocks we get */ - struct block *blockPtr; + register Cache *cachePtr; + register Tcl_Obj *objPtr; + int numMove; + Tcl_Obj *newObjsPtr; + + GETCACHE(cachePtr); /* - * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a - * VAX, I think) or for a negative arg. + * Pop the first object. */ - size = 1 << (bucket + 3); - ASSERT(size > 0); - - amount = MAXMALLOC; - numBlocks = amount / size; - ASSERT(numBlocks*size == amount); - - blockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + amount), 1); - /* no more room! */ - if (blockPtr == NULL) { - return; + if(cachePtr->firstObjPtr) { + haveObj: + objPtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + cachePtr->numObjects--; + return objPtr; } - blockPtr->nextPtr = blockList; - blockList = blockPtr; - - overPtr = (union overhead *) (blockPtr + 1); /* - * Add new memory allocated to that on free list for this hash bucket. + * Do it AFTER looking at the queue, so that it doesn't slow down + * non-purify small allocs. */ - - nextf[bucket] = overPtr; - while (--numBlocks > 0) { - overPtr->next = (union overhead *)((caddr_t)overPtr + size); - overPtr = (union overhead *)((caddr_t)overPtr + size); + + if (TCL_PURIFY) { + Tcl_Obj *objPtr = (Tcl_Obj *) TclpAlloc(sizeof(Tcl_Obj)); + if (objPtr == NULL) { + Tcl_Panic("alloc: could not allocate a new object"); + } + return objPtr; } - overPtr->next = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclpFree -- - * - * Free memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpFree( - char *oldPtr) /* Pointer to memory to free. */ -{ - register long size; - register union overhead *overPtr; - struct block *bigBlockPtr; + + /* + * Get this thread's obj list structure and move or allocate new objs if + * necessary. + */ - if (oldPtr == NULL) { - return; +#if defined(TCL_THREADS) + Tcl_MutexLock(objLockPtr); + numMove = sharedPtr->numObjects; + if (numMove > 0) { + if (numMove > NOBJALLOC) { + numMove = NOBJALLOC; + } + MoveObjs(sharedPtr, cachePtr, numMove); } - - 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; + Tcl_MutexUnlock(objLockPtr); + if (cachePtr->firstObjPtr) { + goto haveObj; } - - RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); - RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); - size = overPtr->bucketIndex; - if (size == 0xff) { -#ifdef MSTATS - numMallocs[NBUCKETS]--; -#endif - - bigBlockPtr = (struct block *) overPtr - 1; - bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; - bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; - TclpSysFree(bigBlockPtr); - - Tcl_MutexUnlock(allocMutexPtr); - return; +#endif + cachePtr->numObjects = numMove = NOBJALLOC; + newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + if (newObjsPtr == NULL) { + Tcl_Panic("alloc: could not allocate %d new objects", numMove); } - ASSERT(size < NBUCKETS); - overPtr->next = nextf[size]; /* also clobbers overMagic */ - nextf[size] = overPtr; - -#ifdef MSTATS - numMallocs[size]--; -#endif - - Tcl_MutexUnlock(allocMutexPtr); + while (--numMove >= 0) { + objPtr = &newObjsPtr[numMove]; + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + } + goto haveObj; } + /* *---------------------------------------------------------------------- * - * TclpRealloc -- + * TclSmallFree -- * - * Reallocate memory. + * Return a free Tcl_Obj-sized block to the per-thread cache. * * Results: * None. * * Side effects: - * None. + * May move free blocks to shared list upon hitting high water mark. * *---------------------------------------------------------------------- */ -char * -TclpRealloc( - char *oldPtr, /* Pointer to alloced block. */ - unsigned int numBytes) /* New size of memory. */ +void +TclSmallFree( + void *ptr) { - 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; + Cache *cachePtr; + Tcl_Obj *objPtr = ptr; + + if (TCL_PURIFY) { + TclpFree((char *) ptr); + return; } - - RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); - RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); - i = overPtr->bucketIndex; + + GETCACHE(cachePtr); /* - * If the block isn't in a bin, just realloc it. + * Get this thread's list and push on the free Tcl_Obj. */ - 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 - -#ifndef NDEBUG - /* - * 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; - } + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + cachePtr->numObjects++; +#if defined(TCL_THREADS) /* - * Ok, we don't have to copy, it fits as-is + * If the number of free objects has exceeded the high water mark, move + * some blocks to the shared list. */ -#ifndef NDEBUG - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - BLOCK_END(overPtr) = RMAGIC; + if (cachePtr->numObjects > NOBJHIGH) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, NOBJALLOC); + Tcl_MutexUnlock(objLockPtr); + } #endif - - Tcl_MutexUnlock(allocMutexPtr); - return(oldPtr); } /* *---------------------------------------------------------------------- * - * mstats -- + * MoveObjs -- * - * Prints two lines of numbers, one showing the length of the free list - * for each size category, the second showing the number of mallocs - - * frees for each size category. + * Move Tcl_Obj's between caches. * * Results: * None. @@ -640,115 +410,38 @@ TclpRealloc( *---------------------------------------------------------------------- */ -#ifdef MSTATS -void -mstats( - char *s) /* Where to write info. */ +#if defined(TCL_THREADS) +static void +MoveObjs( + Cache *fromPtr, + Cache *toPtr, + int numMove) { - register int i, j; - register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; + register Tcl_Obj *objPtr = fromPtr->firstObjPtr; + Tcl_Obj *fromFirstObjPtr = objPtr; - Tcl_MutexLock(allocMutexPtr); + toPtr->numObjects += numMove; + fromPtr->numObjects -= numMove; - fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); - for (i = 0; i < NBUCKETS; i++) { - for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { - fprintf(stderr, " %d", j); - } - totalFree += j * (1 << (i + 3)); - } + /* + * Find the last object to be moved; set the next one (the first one not + * to be moved) as the first object in the 'from' cache. + */ - fprintf(stderr, "\nused:\t"); - for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); - totalUsed += numMallocs[i] * (1 << (i + 3)); + while (--numMove) { + objPtr = objPtr->internalRep.otherValuePtr; } + fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; - fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", - MAXMALLOC, numMallocs[NBUCKETS]); + /* + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. + */ - Tcl_MutexUnlock(allocMutexPtr); + objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + toPtr->firstObjPtr = fromFirstObjPtr; } #endif - -#else /* !USE_TCLALLOC */ - -/* - *---------------------------------------------------------------------- - * - * TclpAlloc -- - * - * Allocate more memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ -{ - return (char *) malloc(numBytes); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFree -- - * - * Free memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpFree( - char *oldPtr) /* Pointer to memory to free. */ -{ - free(oldPtr); - return; -} - -/* - *---------------------------------------------------------------------- - * - * TclpRealloc -- - * - * Reallocate memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpRealloc( - char *oldPtr, /* Pointer to alloced block. */ - unsigned int numBytes) /* New size of memory. */ -{ - return (char *) realloc(oldPtr, numBytes); -} - -#endif /* !USE_TCLALLOC */ -#endif /* !TCL_THREADS */ /* * Local Variables: |