ADDED README.mig-alloc-reform Index: README.mig-alloc-reform ================================================================== --- /dev/null +++ README.mig-alloc-reform @@ -0,0 +1,71 @@ +What is mig-alloc-reform? + 1. A massive simplification of the memory management in Tcl core. + a. removal of the Tcl stack, each BC allocates its own stacklet + b. TclStackAlloc is gone, replaced with ckalloc; goodbye to sometimes + hard sync problems + c. removal of the allocCache slot in struct Interp + d. retirement of the (unused) Tcl allocator USE_TCLALLOC; replacement + with a single-thread special case of zippy + e. unify all allocator options in a single file tclAlloc.c + d. exploit fast TSD via __thread where available (autoconferry still + missing, enable by hand with -DHAVE_FAST_TSD) + f. small improvements in zippy's memory usage: + . try to split blocks in the shared cache before allocating new + ones from the system + . use the same bucket for Tcl_Objs and smallest allocs + + 2. New allocator options + a. purify build (but stop using them, see below). This is suitable to + use with a preloaded malloc replacement + b. (~NEW) native build: call to sys malloc, but maintain zippy's + Tcl_Obj caches (per thread, if threads enabled). Can be switched to + run as a purify build via an env var at startup. This is suitable to + use with a preloaded malloc replacement. The threaded variant is new. + c. zippy build + d. (NEW) multi build: this is a build that can function as any of the + other three. Per default it runs as zippy, but can be switched to + native or purify via an env var at startup. May or may not be used + for deployment, but it will definitely be very useful for + development: no need to recompile in order to valgrind, just set an + env var! + + How do you use it? Options are: + 1. Don't pay any attention to it, build as always. You will get the same + allocator as before + 2. Select the build you want with compiler flags + -DTCL_ALLOCATOR=(aNATIVE|aPURIFY|aZIPPY|aMULTI) + 3. Select behaviour at startup: native can be switched to purify, multi + can be switched to any of the others. Define the env var + TCL_ALLOCATOR when starting up and you're good to go + + +** PERFORMANCE NOTES ** + * do enable HAVE_FAST_TSD on threaded build where available! Without + that it is probably slower than before. Note that __thread is not + available on macosx, but the "slow" version should be quite fast there + (or so they say) + * not measured, but: purify, native and zippy builds should be just as + fast as before. The obj-alloc macros have been removed while + developing. It is not certain that they provide a speedup, this will + be measured and acted accordingly + * multi build should be a only a tad slower, may even be suitable as + default build on all platforms + * zippy stats not enabled by default, -DZIPPY_STATS switches them on + +** TO DO LIST ** + * DEFINITELY + - test like crazy + - timings: versus older version (in unthreaded, fast-tsd and slow-tsd + builds). Determine if the obj-alloc macros should be reenabled + - autoconferry to auto-detect HAVE_FAST_TSD + - autoconferry to choose allocator flags? Keep USE_THREAD_ALLOC and + USE_TCLALLOC for back compat with external build scripts only (and + set them too!), but set also the new variants + TCL_ALLOCATOR=(aNATIVE|aPURIFY|aZIPPY|aMULTI) + - Makefile.in and autoconferry changes in windows, mac + - choose allocators from the command line instead of env vars? + - verify interaction with memdebug (should be 'none', but ...) + + * MAYBE + - build zippy as malloc-replacement, compile always aNATIVE and + preload alternatives Index: generic/tclAlloc.c ================================================================== --- generic/tclAlloc.c +++ generic/tclAlloc.c @@ -1,157 +1,148 @@ /* * 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. - * - * 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. + * This is the generic part of the Tcl allocator. It handles the + * freeObjLists and defines which main allocator will be used. + * + * 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 - -/* - * 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. - */ - -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 OVERHEAD (sizeof(union overhead) + RSLOP) - -/* - * Macro to make it easier to refer to the end-of-block guard magic. - */ - -#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]; - -/* - * 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. - */ - -struct block { - struct block *nextPtr; /* Linked list. */ - struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte - * alignment for suballocated blocks. */ -}; - -static struct block *blockList; /* Tracks the suballocated blocks. */ -static struct block bigBlocks={ /* Big blocks aren't suballocated. */ - &bigBlocks, &bigBlocks -}; - -/* - * 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. - */ - -#ifdef TCL_THREADS -static Tcl_Mutex *allocMutexPtr; -#endif -static int allocInit = 0; - -#ifdef MSTATS - -/* - * numMallocs[i] is the difference between the number of mallocs and frees for - * a given block size. - */ - -static unsigned int numMallocs[NBUCKETS+1]; -#endif - -#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 - -/* - * Prototypes for functions used only in this file. - */ - -static void MoreCore(int bucket); - +#include "tclInt.h" +#include "tclAlloc.h" + +/* + * 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 + */ + +#define NOBJHIGH 1200 +#define NOBJALLOC ((NOBJHIGH*2)/3) + + +/* + * The Tcl_Obj per-thread cache. + */ + +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 */ + + +/* + *---------------------------------------------------------------------- + * + * GetCache --- + * + * Gets per-thread memory cache, allocating it if necessary. + * + * Results: + * Pointer to cache. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +static Cache * +GetCache(void) +{ + Cache *cachePtr; + + /* + * 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 + +/* + * TclSetSharedAllocCache, TclSetAllocCache, TclGetAllocCache + * + * These are utility functions for the loadable allocator. + */ + +void +TclSetSharedAllocCache( + void *allocCachePtr) +{ + sharedPtr->allocCachePtr = allocCachePtr; +} + +void +TclSetAllocCache( + void *allocCachePtr) +{ + Cache *cachePtr; + + GETCACHE(cachePtr); + cachePtr->allocCachePtr = allocCachePtr; +} + +void * +TclGetAllocCache(void) +{ + Cache *cachePtr; + + GETCACHE(cachePtr); + return cachePtr->allocCachePtr; +} + + /* *------------------------------------------------------------------------- * * TclInitAlloc -- * @@ -159,283 +150,258 @@ * * Results: * None. * * Side effects: - * Initialize the mutex used to serialize allocations. + * Initialize the mutex used to serialize obj allocations. + * Call the allocator-specific initialization. * *------------------------------------------------------------------------- */ void TclInitAlloc(void) { - if (!allocInit) { - allocInit = 1; -#ifdef TCL_THREADS - allocMutexPtr = Tcl_GetAllocMutex(); -#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(). - * - * After this function is called, all memory allocated with TclpAlloc() - * should be considered unusable. - * - * 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 -TclFinalizeAllocSubsystem(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; - - for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) { - nextPtr = blockPtr->nextPtr; - TclpSysFree(blockPtr); - blockPtr = nextPtr; - } - bigBlocks.nextPtr = &bigBlocks; - bigBlocks.prevPtr = &bigBlocks; - - for (i=0 ; i= 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); - } - - /* - * Convert amount of memory requested into closest block size stored in - * hash buckets which satisfies request. Account for space used per block - * for accounting. - */ - - 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)); -} - -/* - *---------------------------------------------------------------------- - * - * MoreCore -- - * - * Allocate more memory to the indicated bucket. - * - * Assumes Mutex is already held. - * - * Results: - * None. - * - * Side effects: - * Attempts to get more memory from the system. - * - *---------------------------------------------------------------------- - */ - -static void -MoreCore( - int bucket) /* What bucket to allocat to. */ -{ - 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; - - /* - * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a - * VAX, I think) or for a negative arg. - */ - - 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; - } - blockPtr->nextPtr = blockList; - blockList = blockPtr; - - overPtr = (union overhead *) (blockPtr + 1); - - /* - * Add new memory allocated to that on free list for this hash bucket. - */ - - nextf[bucket] = overPtr; - while (--numBlocks > 0) { - overPtr->next = (union overhead *)((caddr_t)overPtr + size); - overPtr = (union overhead *)((caddr_t)overPtr + size); - } - overPtr->next = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclpFree -- - * - * Free memory. + /* + * 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 +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAlloc -- + * + * This procedure is used to destroy all private resources used in this + * file. + * + * Results: + * None. + * + * Side effects: + * Call the allocator-specific finalization. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAlloc(void) +{ +#if defined(TCL_THREADS) + + TclpFreeAllocMutex(objLockPtr); + objLockPtr = NULL; + + TclpFreeAllocCache(NULL); +#endif + TclXpFinalizeAlloc(); +} + +/* + *---------------------------------------------------------------------- + * + * TclFreeAllocCache -- + * + * Flush and delete a cache, removing from list of caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +void +TclFreeAllocCache( + void *arg) +{ + Cache *cachePtr = arg; + + /* + * Flush objs. + */ + + if (cachePtr->numObjects > 0) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); + Tcl_MutexUnlock(objLockPtr); + } + + /* + * Flush the external allocator cache + */ + + TclXpFreeAllocCache(cachePtr->allocCachePtr); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclSmallAlloc -- + * + * Allocate a Tcl_Obj sized block from the per-thread cache. + * + * Results: + * Pointer to uninitialized memory. + * + * Side effects: + * May move blocks from shared cached or allocate new blocks if + * list is empty. + * + *---------------------------------------------------------------------- + */ + +void * +TclSmallAlloc(void) +{ + register Cache *cachePtr; + register Tcl_Obj *objPtr; + int numMove; + Tcl_Obj *newObjsPtr; + + GETCACHE(cachePtr); + + /* + * Pop the first object. + */ + + if(cachePtr->firstObjPtr) { + haveObj: + objPtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + cachePtr->numObjects--; + return objPtr; + } + + /* + * Do it AFTER looking at the queue, so that it doesn't slow down + * non-purify small allocs. + */ + + 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; + } + + /* + * Get this thread's obj list structure and move or allocate new objs if + * necessary. + */ + +#if defined(TCL_THREADS) + Tcl_MutexLock(objLockPtr); + numMove = sharedPtr->numObjects; + if (numMove > 0) { + if (numMove > NOBJALLOC) { + numMove = NOBJALLOC; + } + MoveObjs(sharedPtr, cachePtr, numMove); + } + Tcl_MutexUnlock(objLockPtr); + if (cachePtr->firstObjPtr) { + goto haveObj; + } +#endif + cachePtr->numObjects = numMove = NOBJALLOC; + newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + if (newObjsPtr == NULL) { + Tcl_Panic("alloc: could not allocate %d new objects", numMove); + } + while (--numMove >= 0) { + objPtr = &newObjsPtr[numMove]; + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + } + goto haveObj; +} + + +/* + *---------------------------------------------------------------------- + * + * TclSmallFree -- + * + * Return a free Tcl_Obj-sized block to the per-thread cache. + * + * Results: + * None. + * + * Side effects: + * May move free blocks to shared list upon hitting high water mark. + * + *---------------------------------------------------------------------- + */ + +void +TclSmallFree( + void *ptr) +{ + Cache *cachePtr; + Tcl_Obj *objPtr = ptr; + + if (TCL_PURIFY) { + TclpFree((char *) ptr); + return; + } + + GETCACHE(cachePtr); + + /* + * Get this thread's list and push on the free Tcl_Obj. + */ + + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + cachePtr->numObjects++; + +#if defined(TCL_THREADS) + /* + * If the number of free objects has exceeded the high water mark, move + * some blocks to the shared list. + */ + + if (cachePtr->numObjects > NOBJHIGH) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, NOBJALLOC); + Tcl_MutexUnlock(objLockPtr); + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * MoveObjs -- + * + * Move Tcl_Obj's between caches. * * Results: * None. * * Side effects: @@ -442,318 +408,45 @@ * None. * *---------------------------------------------------------------------- */ -void -TclpFree( - char *oldPtr) /* Pointer to memory to free. */ -{ - register long size; - register union overhead *overPtr; - struct block *bigBlockPtr; - - if (oldPtr == NULL) { - return; - } - - 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; - } - - 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; - } - ASSERT(size < NBUCKETS); - overPtr->next = nextf[size]; /* also clobbers overMagic */ - nextf[size] = overPtr; - -#ifdef MSTATS - numMallocs[size]--; -#endif - - Tcl_MutexUnlock(allocMutexPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpRealloc -- - * - * Reallocate memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -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 - -#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; - } - - /* - * Ok, we don't have to copy, it fits as-is - */ - -#ifndef NDEBUG - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - BLOCK_END(overPtr) = RMAGIC; -#endif - - Tcl_MutexUnlock(allocMutexPtr); - return(oldPtr); -} - -/* - *---------------------------------------------------------------------- - * - * mstats -- - * - * 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. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef MSTATS -void -mstats( - char *s) /* Where to write info. */ -{ - register int i, j; - register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; - - Tcl_MutexLock(allocMutexPtr); - - 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)); - } - - fprintf(stderr, "\nused:\t"); - for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); - totalUsed += numMallocs[i] * (1 << (i + 3)); - } - - 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]); - - Tcl_MutexUnlock(allocMutexPtr); -} -#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 */ +#if defined(TCL_THREADS) +static void +MoveObjs( + Cache *fromPtr, + Cache *toPtr, + int numMove) +{ + register Tcl_Obj *objPtr = fromPtr->firstObjPtr; + Tcl_Obj *fromFirstObjPtr = objPtr; + + toPtr->numObjects += numMove; + fromPtr->numObjects -= numMove; + + /* + * 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. + */ + + while (--numMove) { + objPtr = objPtr->internalRep.otherValuePtr; + } + fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + + /* + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. + */ + + objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + toPtr->firstObjPtr = fromFirstObjPtr; +} +#endif /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ ADDED generic/tclAlloc.h Index: generic/tclAlloc.h ================================================================== --- /dev/null +++ generic/tclAlloc.h @@ -0,0 +1,49 @@ +/* + * tclAlloc.h -- + * + * This defines the interface for pluggable memory allocators for Tcl. + * + * 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. + */ + +#ifndef _TCLALLOC +#define _TCLALLOC + +/* + * These functions must be exported by the allocator. + */ + +char * TclpAlloc(unsigned int reqSize); +char * TclpRealloc(char *ptr, unsigned int reqSize); +void TclpFree(char *ptr); +void * TclSmallAlloc(void); +void TclSmallFree(void *ptr); + +void TclInitAlloc(void); +void TclFinalizeAlloc(void); +void TclFreeAllocCache(void *ptr); + +/* + * The allocator should allow for "purify mode" by checking the environment + * variable TCL_PURIFY at initialization. If it is set to any value, it should + * just shunt to plain malloc. This is used for debugging; the value can be + * treated as a constant, it does not change in a running process. + */ + +/* + * This macro is used to properly align the memory allocated by Tcl, giving + * the same alignment as the native malloc. + */ + +#if defined(__APPLE__) +#define ALLOCALIGN 16 +#else +#define ALLOCALIGN (2*sizeof(void *)) +#endif + +#define ALIGN(x) (((x) + ALLOCALIGN - 1) & ~(ALLOCALIGN - 1)) + +#endif ADDED generic/tclAllocNative.c Index: generic/tclAllocNative.c ================================================================== --- /dev/null +++ generic/tclAllocNative.c @@ -0,0 +1,36 @@ +/* + * tclAllocNative.c -- + * + * This is the basic native allocator for Tcl, using zippy's per-thread + * free obj lists. + * + * 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. + */ + +#define OBJQ_ONLY 1 +#include "tclAllocZippy.c" + +char * +TclpAlloc( + unsigned int reqSize) +{ + return malloc(reqSize); +} + +char * +TclpRealloc( + char *ptr, + unsigned int reqSize) +{ + return realloc(ptr, reqSize); +} + +void +TclpFree( + char *ptr) +{ + free(ptr); +} ADDED generic/tclAllocPurify.c Index: generic/tclAllocPurify.c ================================================================== --- /dev/null +++ generic/tclAllocPurify.c @@ -0,0 +1,66 @@ +/* + * tclAllocPurify.c -- + * + * This is the native allocator for Tcl, suitable for preloading anything else. + * + * 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. + */ + +/* This is needed just for sizeof(Tcl_Obj) and malloc*/ + +#include "tclInt.h" + +char * +TclpAlloc( + unsigned int reqSize) +{ + return malloc(reqSize); +} + +char * +TclpRealloc( + char *ptr, + unsigned int reqSize) +{ + return realloc(ptr, reqSize); +} + +void +TclpFree( + char *ptr) +{ + free(ptr); +} + +void * +TclSmallAlloc(void) +{ + return malloc(sizeof(Tcl_Obj)); +} + +void +TclSmallFree( + void *ptr) +{ + free(ptr); +} + +void +TclInitAlloc(void) +{ +} + +void +TclFinalizeAlloc(void) +{ +} + +void +TclFreeAllocCache( + void *ptr) +{ +} + ADDED generic/tclAllocZippy.c Index: generic/tclAllocZippy.c ================================================================== --- /dev/null +++ generic/tclAllocZippy.c @@ -0,0 +1,1135 @@ +/* + * tclAllocZippy.c -- + * + * This is a very fast storage allocator for used with threads (designed + * avoid lock contention). The basic strategy is to allocate memory in + * fixed size blocks from block caches. + * + * The Initial Developer of the Original Code is America Online, Inc. + * Portions created by AOL are Copyright (C) 1999 America Online, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" + +#define NATIVE_T (defined(OBJQ_ONLY) && defined(TCL_THREADS)) +#define NATIVE_U (defined(OBJQ_ONLY) && !defined(TCL_THREADS)) +#define NATIVE (NATIVE_T || NATIVE_U) +#define ZIPPY_T (!defined(OBJQ_ONLY) && defined(TCL_THREADS)) +#define ZIPPY_U (!defined(OBJQ_ONLY) && !defined(TCL_THREADS)) +#define ZIPPY (ZIPPY_T || ZIPPY_U) + +/* + * The following define the number of Tcl_Obj's to allocate/move at a time and + * the high water mark to prune a per-thread cache. On a 32 bit system, + * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k. + */ + +#define NOBJHIGH 1200 +#define NOBJALLOC ((2*NOBJHIGH)/3) + +#if ZIPPY +/* + * If range checking is enabled, an additional byte will be allocated to store + * the magic number at the end of the requested memory. + */ + +#ifndef RCHECK +#ifdef NDEBUG +#define RCHECK 0 +#else +#define RCHECK 1 +#endif +#endif + +/* + * This macro is used to properly align the memory allocated by Tcl, giving + * the same alignment as the native malloc. + */ + +#if defined(__APPLE__) +#define TCL_ALLOCALIGN 16 +#else +#define TCL_ALLOCALIGN (2*sizeof(void *)) +#endif + +#define ALIGN(x) (((x) + TCL_ALLOCALIGN - 1) & ~(TCL_ALLOCALIGN - 1)) + + +/* + * The following union stores accounting information for each block including + * two small magic numbers and a bucket number when in use or a next pointer + * when free. The original requested size (not including the Block overhead) + * is also maintained. + */ + +typedef union Block { + struct { + union { + union Block *next; /* Next in free list. */ + struct { + unsigned char magic1; /* First magic number. */ + unsigned char bucket; /* Bucket block allocated from. */ + unsigned char unused; /* Padding. */ + unsigned char magic2; /* Second magic number. */ + } s; + } u; + size_t reqSize; /* Requested allocation size. */ + } b; + unsigned char padding[TCL_ALLOCALIGN]; +} Block; +#define nextBlock b.u.next +#define sourceBucket b.u.s.bucket +#define magicNum1 b.u.s.magic1 +#define magicNum2 b.u.s.magic2 +#define MAGIC 0xEF +#define blockReqSize b.reqSize + +/* + * The following defines the minimum and and maximum block sizes and the number + * of buckets in the bucket cache. + */ + +#define MINALLOC ((sizeof(Block) + 8 + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) +#define NBUCKETS (11 - (MINALLOC >> 5)) +#define MAXALLOC (MINALLOC << (NBUCKETS - 1)) + +/* + * The following structure defines a bucket of blocks with various accounting + * and statistics information. + */ + +typedef struct Bucket { + Block *firstPtr; /* First block available */ + long numFree; /* Number of blocks available */ + + /* All fields below for accounting only */ +#if ZIPPY + long numRemoves; /* Number of removes from bucket */ + long numInserts; /* Number of inserts into bucket */ + long numWaits; /* Number of waits to acquire a lock */ + long numLocks; /* Number of locks acquired */ + long totalAssigned; /* Total space assigned to bucket */ +#endif +} Bucket; + +#endif /* ZIPPY */ + +/* + * The following structure defines a cache of buckets and objs, of which there + * will be (at most) one per thread. Any changes need to be reflected in the + * struct AllocCache defined in tclInt.h, possibly also in the initialisation + * code in Tcl_CreateInterp(). + */ + +typedef struct Cache { + Tcl_Obj *firstObjPtr; /* List of free objects for thread */ + int numObjects; /* Number of objects for thread */ +#if ZIPPY + struct Cache *nextPtr; /* Linked list of cache entries */ + int totalAssigned; /* Total space assigned to thread */ + Bucket buckets[NBUCKETS]; /* The buckets for this thread */ + Tcl_ThreadId owner; /* Which thread's cache is this? */ +#endif +} Cache; + +#if ZIPPY +/* + * The following array specifies various per-bucket limits and locks. The + * values are statically initialized to avoid calculating them repeatedly. + */ + +static struct { + size_t blockSize; /* Bucket blocksize. */ + int maxBlocks; /* Max blocks before move to share. */ +#if ZIPPY_T + int numMove; /* Num blocks to move to share. */ + Tcl_Mutex *lockPtr; /* Share bucket lock. */ +#endif +} bucketInfo[NBUCKETS]; + +#endif /* ZIPPY */ + +/* + * Static functions defined in this file. + */ + +#if ZIPPY + +#if ZIPPY_T +static Cache * GetCache(void); +static void LockBucket(Cache *cachePtr, int bucket); +static void UnlockBucket(Cache *cachePtr, int bucket); +static void PutBlocks(Cache *cachePtr, int bucket, int numMove); +static int GetBlocks(Cache *cachePtr, int bucket); +#else /* ZIPPY_U */ +#define GetBlocks(cachePtr, bucket) 0 +#endif /* ZIPPY_U */ + +static void InitBuckets(void); +static Block * Ptr2Block(char *ptr); +static char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); +#endif /* ZIPPY */ + +#ifdef TCL_THREADS +static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); +#endif + +/* + * Local variables defined in this file and initialized at startup. + */ + +static Cache sharedCache; +static Cache *sharedPtr = &sharedCache; + +#ifdef TCL_THREADS + +static Tcl_Mutex *objLockPtr; + +#if ZIPPY_T +static Tcl_Mutex *listLockPtr; +static Cache *firstCachePtr = &sharedCache; +#endif + +#if defined(HAVE_FAST_TSD) +static __thread Cache *tcachePtr; + +# define GETCACHE(cachePtr) \ + do { \ + if (!tcachePtr) { \ + tcachePtr = GetCache(); \ + } \ + (cachePtr) = tcachePtr; \ + } while (0) +#else /* FAST_TSD */ +# define GETCACHE(cachePtr) \ + do { \ + (cachePtr) = TclpGetAllocCache(); \ + if ((cachePtr) == NULL) { \ + (cachePtr) = GetCache(); \ + } \ + } while (0) +#endif /* FAST_TSD */ + +#else /* TCL_THREADS */ + +#define GETCACHE(cachePtr) \ + (cachePtr) = sharedPtr +#endif + +/* + *---------------------------------------------------------------------- + * + * GetCache --- + * + * Gets per-thread memory cache, allocating it if necessary. + * + * Results: + * Pointer to cache. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if ZIPPY +static void +InitBuckets(void) +{ + int i; + + for (i = 0; i < NBUCKETS; ++i) { + bucketInfo[i].blockSize = MINALLOC << i; + bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); +#if ZIPPY_T + bucketInfo[i].numMove = i < NBUCKETS - 1 ? + 1 << (NBUCKETS - 2 - i) : 1; + bucketInfo[i].lockPtr = TclpNewAllocMutex(); +#endif + } +} +#endif + +#ifdef TCL_THREADS +static Cache * +GetCache(void) +{ + Cache *cachePtr; + + /* + * 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"); + } +#if ZIPPY_T + Tcl_MutexLock(listLockPtr); + cachePtr->nextPtr = firstCachePtr; + firstCachePtr = cachePtr; + Tcl_MutexUnlock(listLockPtr); + cachePtr->owner = Tcl_GetCurrentThread(); +#endif + TclpSetAllocCache(cachePtr); + } + return cachePtr; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclFreeAllocCache -- + * + * Flush and delete a cache, removing from list of caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +#ifdef TCL_THREADS +void +TclFreeAllocCache( + void *arg) +{ + Cache *cachePtr = arg; +#if ZIPPY_T + Cache **nextPtrPtr; + register unsigned int bucket; + + /* + * Flush blocks. + */ + + for (bucket = 0; bucket < NBUCKETS; ++bucket) { + if (cachePtr->buckets[bucket].numFree > 0) { + PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].numFree); + } + } + + /* + * Remove from pool list. + */ + + Tcl_MutexLock(listLockPtr); + nextPtrPtr = &firstCachePtr; + while (*nextPtrPtr != cachePtr) { + nextPtrPtr = &(*nextPtrPtr)->nextPtr; + } + *nextPtrPtr = cachePtr->nextPtr; + cachePtr->nextPtr = NULL; + Tcl_MutexUnlock(listLockPtr); +#endif + + /* + * Flush objs. + */ + + if (cachePtr->numObjects > 0) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); + Tcl_MutexUnlock(objLockPtr); + } + + free(cachePtr); +} +#endif /* TCL_THREADS */ + +/* + *---------------------------------------------------------------------- + * + * TclpAlloc -- + * + * Allocate memory. + * + * Results: + * Pointer to memory just beyond Block pointer. + * + * Side effects: + * May allocate more blocks for a bucket. + * + *---------------------------------------------------------------------- + */ +#if ZIPPY + +char * +TclpAlloc( + unsigned int reqSize) +{ + Cache *cachePtr; + Block *blockPtr; + register int bucket; + size_t size; + +#ifndef __LP64__ + 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; + } + } +#endif + + GETCACHE(cachePtr); + + /* + * Increment the requested size to include room for the Block structure. + * Call malloc() directly if the required amount is greater than the + * largest block, otherwise pop the smallest block large enough, + * allocating more blocks if necessary. + */ + + blockPtr = NULL; + size = reqSize + sizeof(Block); +#if RCHECK + size++; +#endif + if (size > MAXALLOC) { + bucket = NBUCKETS; + blockPtr = malloc(size); + if (blockPtr != NULL) { + cachePtr->totalAssigned += reqSize; + } + } else { + bucket = 0; + while (bucketInfo[bucket].blockSize < size) { + bucket++; + } + if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) { + blockPtr = cachePtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock; +#if ZIPPY_T + cachePtr->buckets[bucket].numFree--; + cachePtr->buckets[bucket].numRemoves++; + cachePtr->buckets[bucket].totalAssigned += reqSize; +#endif + } + } + if (blockPtr == NULL) { + return NULL; + } + return Block2Ptr(blockPtr, bucket, reqSize); +} + +/* + *---------------------------------------------------------------------- + * + * TclpFree -- + * + * Return blocks to the thread block cache. + * + * Results: + * None. + * + * Side effects: + * May move blocks to shared cache. + * + *---------------------------------------------------------------------- + */ + +void +TclpFree( + char *ptr) +{ + Cache *cachePtr; + Block *blockPtr; + int bucket; + + if (ptr == NULL) { + return; + } + + GETCACHE(cachePtr); + + /* + * Get the block back from the user pointer and call system free directly + * for large blocks. Otherwise, push the block back on the bucket and move + * blocks to the shared cache if there are now too many free. + */ + + blockPtr = Ptr2Block(ptr); + bucket = blockPtr->sourceBucket; + if (bucket == NBUCKETS) { + cachePtr->totalAssigned -= blockPtr->blockReqSize; + free(blockPtr); + return; + } + + cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; + blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr; + cachePtr->buckets[bucket].numFree++; + cachePtr->buckets[bucket].numInserts++; + +#if ZIPPY_T + if (cachePtr != sharedPtr && + cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { + PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclpRealloc -- + * + * Re-allocate memory to a larger or smaller size. + * + * Results: + * Pointer to memory just beyond Block pointer. + * + * Side effects: + * Previous memory, if any, may be freed. + * + *---------------------------------------------------------------------- + */ + +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); + } + +#ifndef __LP64__ + 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; + } + } +#endif + + GETCACHE(cachePtr); + + /* + * 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; +} +#endif /* OBJQ_ONLY */ + +/* + *---------------------------------------------------------------------- + * + * TclSmallAlloc -- + * + * Allocate a Tcl_Obj from the per-thread cache. + * + * Results: + * Pointer to uninitialized Tcl_Obj. + * + * Side effects: + * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if + * list is empty. + * + * Note: + * If this code is updated, the changes need to be reflected in the macro + * TclAllocObjStorageEx() defined in tclInt.h + * + *---------------------------------------------------------------------- + */ + +void * +TclSmallAlloc(void) +{ + register Cache *cachePtr; + register Tcl_Obj *objPtr; + register int numMove; + + + GETCACHE(cachePtr); + + /* + * Get this thread's obj list structure and move or allocate new objs if + * necessary. + */ + +#if ZIPPY_T + if (cachePtr->numObjects == 0) { + Tcl_MutexLock(objLockPtr); + numMove = sharedPtr->numObjects; + if (numMove > 0) { + if (numMove > NOBJALLOC) { + numMove = NOBJALLOC; + } + MoveObjs(sharedPtr, cachePtr, numMove); + } + Tcl_MutexUnlock(objLockPtr); + } +#endif + + if (cachePtr->numObjects == 0) { + Tcl_Obj *newObjsPtr; + + cachePtr->numObjects = numMove = NOBJALLOC; + newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + if (newObjsPtr == NULL) { + Tcl_Panic("alloc: could not allocate %d new objects", numMove); + } + while (--numMove >= 0) { + objPtr = &newObjsPtr[numMove]; + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + } + } + + /* + * Pop the first object. + */ + + objPtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + cachePtr->numObjects--; + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclSmallFree -- + * + * Return a free Tcl_Obj to the per-thread cache. + * + * Results: + * None. + * + * Side effects: + * May move free Tcl_Obj's to shared list upon hitting high water mark. + * + * Note: + * If this code is updated, the changes need to be reflected in the macro + * TclAllocObjStorageEx() defined in tclInt.h + * + *---------------------------------------------------------------------- + */ + +void +TclSmallFree( + void *ptr) +{ + Cache *cachePtr; + Tcl_Obj *objPtr = ptr; + + GETCACHE(cachePtr); + + /* + * Get this thread's list and push on the free Tcl_Obj. + */ + + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + cachePtr->numObjects++; + + /* + * If the number of free objects has exceeded the high water mark, move + * some blocks to the shared list. + */ +#if ZIPPY_T + if (cachePtr->numObjects > NOBJHIGH) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, NOBJALLOC); + Tcl_MutexUnlock(objLockPtr); + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMemoryInfo -- + * + * Return a list-of-lists of memory stats. + * + * Results: + * None. + * + * Side effects: + * List appended to given dstring. + * + *---------------------------------------------------------------------- + */ + +#if ZIPPY_T +void +Tcl_GetMemoryInfo( + Tcl_DString *dsPtr) +{ + Cache *cachePtr; + char buf[200]; + unsigned int n; + + Tcl_MutexLock(listLockPtr); + cachePtr = firstCachePtr; + while (cachePtr != NULL) { + Tcl_DStringStartSublist(dsPtr); + if (cachePtr == sharedPtr) { + Tcl_DStringAppendElement(dsPtr, "shared"); + } else { + sprintf(buf, "thread%p", cachePtr->owner); + Tcl_DStringAppendElement(dsPtr, buf); + } + for (n = 0; n < NBUCKETS; ++n) { + sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld", + (unsigned long) bucketInfo[n].blockSize, + cachePtr->buckets[n].numFree, + cachePtr->buckets[n].numRemoves, + cachePtr->buckets[n].numInserts, + cachePtr->buckets[n].totalAssigned, + cachePtr->buckets[n].numLocks, + cachePtr->buckets[n].numWaits); + Tcl_DStringAppendElement(dsPtr, buf); + } + Tcl_DStringEndSublist(dsPtr); + cachePtr = cachePtr->nextPtr; + } + Tcl_MutexUnlock(listLockPtr); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * MoveObjs -- + * + * Move Tcl_Obj's between caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_THREADS + +static void +MoveObjs( + Cache *fromPtr, + Cache *toPtr, + int numMove) +{ + register Tcl_Obj *objPtr = fromPtr->firstObjPtr; + Tcl_Obj *fromFirstObjPtr = objPtr; + + toPtr->numObjects += numMove; + fromPtr->numObjects -= numMove; + + /* + * 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. + */ + + while (--numMove) { + objPtr = objPtr->internalRep.otherValuePtr; + } + fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + + /* + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. + */ + + objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + toPtr->firstObjPtr = fromFirstObjPtr; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * Block2Ptr, Ptr2Block -- + * + * Convert between internal blocks and user pointers. + * + * Results: + * User pointer or internal block. + * + * Side effects: + * Invalid blocks will abort the server. + * + *---------------------------------------------------------------------- + */ + +#if ZIPPY + +static char * +Block2Ptr( + Block *blockPtr, + int bucket, + unsigned int reqSize) +{ + register void *ptr; + + blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC; + blockPtr->sourceBucket = bucket; + blockPtr->blockReqSize = reqSize; + ptr = ((void *) (blockPtr + 1)); +#if RCHECK + ((unsigned char *)(ptr))[reqSize] = MAGIC; +#endif + return (char *) ptr; +} + +static Block * +Ptr2Block( + char *ptr) +{ + register Block *blockPtr; + + blockPtr = (((Block *) ptr) - 1); + if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) { + Tcl_Panic("alloc: invalid block: %p: %x %x", + blockPtr, blockPtr->magicNum1, blockPtr->magicNum2); + } +#if RCHECK + if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) { + Tcl_Panic("alloc: invalid block: %p: %x %x %x", + blockPtr, blockPtr->magicNum1, blockPtr->magicNum2, + ((unsigned char *) ptr)[blockPtr->blockReqSize]); + } +#endif + return blockPtr; +} +#endif /* ZIPPY */ + +/* + *---------------------------------------------------------------------- + * + * LockBucket, UnlockBucket -- + * + * Set/unset the lock to access a bucket in the shared cache. + * + * Results: + * None. + * + * Side effects: + * Lock activity and contention are monitored globally and on a per-cache + * basis. + * + *---------------------------------------------------------------------- + */ + +#if ZIPPY_T + +static void +LockBucket( + Cache *cachePtr, + int bucket) +{ + Tcl_MutexLock(bucketInfo[bucket].lockPtr); + cachePtr->buckets[bucket].numLocks++; + sharedPtr->buckets[bucket].numLocks++; +} + +static void +UnlockBucket( + Cache *cachePtr, + int bucket) +{ + Tcl_MutexUnlock(bucketInfo[bucket].lockPtr); +} +#endif /* ZIPPY_T */ + +/* + *---------------------------------------------------------------------- + * + * PutBlocks -- + * + * Return unused blocks to the shared cache. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if ZIPPY_T + +static void +PutBlocks( + Cache *cachePtr, + int bucket, + int numMove) +{ + register Block *lastPtr, *firstPtr; + register int n = numMove; + + /* + * Before acquiring the lock, walk the block list to find the last block + * to be moved. + */ + + firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; + while (--n > 0) { + lastPtr = lastPtr->nextBlock; + } + cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; + cachePtr->buckets[bucket].numFree -= numMove; + + /* + * Aquire the lock and place the list of blocks at the front of the shared + * cache bucket. + */ + + LockBucket(cachePtr, bucket); + lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; + sharedPtr->buckets[bucket].firstPtr = firstPtr; + sharedPtr->buckets[bucket].numFree += numMove; + UnlockBucket(cachePtr, bucket); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * GetBlocks -- + * + * Get more blocks for a bucket. + * + * Results: + * 1 if blocks where allocated, 0 otherwise. + * + * Side effects: + * Cache may be filled with available blocks. + * + *---------------------------------------------------------------------- + */ + +#if ZIPPY_T +static int +GetBlocks( + Cache *cachePtr, + int bucket) +{ + register Block *blockPtr; + register int n; + + /* + * First, atttempt to move blocks from the shared cache. Note the + * potentially dirty read of numFree before acquiring the lock which is a + * slight performance enhancement. The value is verified after the lock is + * actually acquired. + */ + + if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) { + LockBucket(cachePtr, bucket); + if (sharedPtr->buckets[bucket].numFree > 0) { + + /* + * Either move the entire list or walk the list to find the last + * block to move. + */ + + n = bucketInfo[bucket].numMove; + if (n >= sharedPtr->buckets[bucket].numFree) { + cachePtr->buckets[bucket].firstPtr = + sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].numFree = + sharedPtr->buckets[bucket].numFree; + sharedPtr->buckets[bucket].firstPtr = NULL; + sharedPtr->buckets[bucket].numFree = 0; + } else { + blockPtr = sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr; + sharedPtr->buckets[bucket].numFree -= n; + cachePtr->buckets[bucket].numFree = n; + while (--n > 0) { + blockPtr = blockPtr->nextBlock; + } + sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; + blockPtr->nextBlock = NULL; + } + } + UnlockBucket(cachePtr, bucket); + } + + if (cachePtr->buckets[bucket].numFree == 0) { + register size_t size; + + /* + * If no blocks could be moved from shared, first look for a larger + * block in this cache to split up. + */ + + blockPtr = NULL; + n = NBUCKETS; + size = 0; /* lint */ + while (--n > bucket) { + if (cachePtr->buckets[n].numFree > 0) { + size = bucketInfo[n].blockSize; + blockPtr = cachePtr->buckets[n].firstPtr; + cachePtr->buckets[n].firstPtr = blockPtr->nextBlock; + cachePtr->buckets[n].numFree--; + break; + } + } + + /* + * Otherwise, allocate a big new block directly. + */ + + if (blockPtr == NULL) { + size = MAXALLOC; + blockPtr = malloc(size); + if (blockPtr == NULL) { + Tcl_Panic("FOO\n"); + return 0; + } + } + + /* + * Split the larger block into smaller blocks for this bucket. + */ + + n = size / bucketInfo[bucket].blockSize; + cachePtr->buckets[bucket].numFree = n; + cachePtr->buckets[bucket].firstPtr = blockPtr; + while (--n > 0) { + blockPtr->nextBlock = (Block *) + ((char *) blockPtr + bucketInfo[bucket].blockSize); + blockPtr = blockPtr->nextBlock; + } + blockPtr->nextBlock = NULL; + } + return 1; +} +#endif /* ZIPPY_T */ + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAlloc -- + * + * This procedure is used to destroy all private resources used in this + * file. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclInitAlloc(void) +{ +#ifdef TCL_THREADS +#if ZIPPY_T + listLockPtr = TclpNewAllocMutex(); + InitBuckets(); +#endif + objLockPtr = TclpNewAllocMutex(); +#endif + +#if ZIPPY_U + InitBuckets(); +#endif +} + +void +TclFinalizeAlloc(void) +{ +#ifdef TCL_THREADS +#if ZIPPY_T + unsigned int i; + + for (i = 0; i < NBUCKETS; ++i) { + TclpFreeAllocMutex(bucketInfo[i].lockPtr); + bucketInfo[i].lockPtr = NULL; + } + + TclpFreeAllocMutex(listLockPtr); + listLockPtr = NULL; +#endif + + TclpFreeAllocMutex(objLockPtr); + objLockPtr = NULL; + + TclpFreeAllocCache(NULL); +#endif +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ generic/tclAssembly.c @@ -1162,15 +1162,13 @@ NewAssemblyEnv( CompileEnv* envPtr, /* Compilation environment being used for code * generation*/ int flags) /* Compilation flags (TCL_EVAL_DIRECT) */ { - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv)); + AssemblyEnv* assemEnvPtr = ckalloc(sizeof(AssemblyEnv)); /* Assembler environment under construction */ - Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse* parsePtr = ckalloc(sizeof(Tcl_Parse)); /* Parse of one line of assembly code */ assemEnvPtr->envPtr = envPtr; assemEnvPtr->parsePtr = parsePtr; assemEnvPtr->cmdLine = envPtr->line; @@ -1211,15 +1209,10 @@ static void FreeAssemblyEnv( AssemblyEnv* assemEnvPtr) /* Environment to free */ { - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment being used for code - * generation */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ BasicBlock* thisBB; /* Pointer to a basic block being deleted */ BasicBlock* nextBB; /* Pointer to a deleted basic block's * successor */ /* @@ -1244,12 +1237,12 @@ /* * Dispose what's left. */ Tcl_DeleteHashTable(&assemEnvPtr->labelHash); - TclStackFree(interp, assemEnvPtr->parsePtr); - TclStackFree(interp, assemEnvPtr); + ckfree(assemEnvPtr->parsePtr); + ckfree(assemEnvPtr); } /* *----------------------------------------------------------------------------- * Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -723,16 +723,10 @@ /* * Initialise the thread-specific data ekeko. Note that the thread's alloc * cache was already initialised by the call to alloc the interp struct. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - iPtr->allocCache = TclpGetAllocCache(); -#else - iPtr->allocCache = NULL; -#endif - iPtr->pendingObjDataPtr = NULL; iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); iPtr->deferredCallbacks = NULL; /* * Create the core commands. Do it here, rather than calling @@ -2356,12 +2350,11 @@ register int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr = clientData; int i, result; - const char **argv = - TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); + const char **argv = ckalloc((unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -2370,11 +2363,11 @@ * Invoke the command's string-based Tcl_CmdProc. */ result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); return result; } /* *---------------------------------------------------------------------- @@ -2405,12 +2398,11 @@ register const char **argv) /* Argument strings. */ { Command *cmdPtr = clientData; Tcl_Obj *objPtr; int i, length, result; - Tcl_Obj **objv = - TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); + Tcl_Obj **objv = ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); for (i = 0; i < argc; i++) { length = strlen(argv[i]); TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); @@ -2442,11 +2434,11 @@ for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } - TclStackFree(interp, objv); + ckfree(objv); return result; } /* *---------------------------------------------------------------------- @@ -4573,11 +4565,11 @@ */ Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; - newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); + newObjv = ckalloc((int) sizeof(Tcl_Obj *) * newObjc); /* * Copy command prefix from unknown handler and add on the real command's * full argument list. Note that we only use memcpy() once because we have * to increment the reference count of all the handler arguments anyway. @@ -4612,11 +4604,11 @@ */ for (i = 0; i < handlerObjc; ++i) { Tcl_DecrRefCount(newObjv[i]); } - TclStackFree(interp, newObjv); + ckfree(newObjv); return TCL_ERROR; } if (lookupNsPtr) { savedNsPtr = varFramePtr->nsPtr; @@ -4650,11 +4642,11 @@ */ for (i = 0; i < objc; ++i) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(interp, objv); + ckfree(objv); return result; } static int @@ -4947,16 +4939,15 @@ unsigned int i, objectsUsed = 0; /* These variables keep track of how much * state has been allocated while evaluating * the script, so that it can be freed * properly if an error occurs. */ - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); - CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); - Tcl_Obj **stackObjArray = - TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); - int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int)); - int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); + CmdFrame *eeFramePtr = ckalloc(sizeof(CmdFrame)); + Tcl_Obj **stackObjArray = ckalloc(minObjs * sizeof(Tcl_Obj *)); + int *expandStack = ckalloc(minObjs * sizeof(int)); + int *linesStack = ckalloc(minObjs * sizeof(int)); /* TIP #280 Structures for tracking of command * locations. */ int *clNext = NULL; /* Pointer for the tracking of invisible * continuation lines. Initialized only if the * caller gave us a table of locations to @@ -5348,15 +5339,15 @@ iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eeFramePtr->data.eval.path); } - TclStackFree(interp, linesStack); - TclStackFree(interp, expandStack); - TclStackFree(interp, stackObjArray); - TclStackFree(interp, eeFramePtr); - TclStackFree(interp, parsePtr); + ckfree(linesStack); + ckfree(expandStack); + ckfree(stackObjArray); + ckfree(eeFramePtr); + ckfree(parsePtr); return code; } /* @@ -5988,11 +5979,11 @@ * * Note that we use (word==INTMIN) to signal that no command frame * should be pushed, as needed by alias and ensemble redirections. */ - eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); + eoFramePtr = ckalloc(sizeof(CmdFrame)); eoFramePtr->nline = 0; eoFramePtr->line = NULL; eoFramePtr->type = TCL_LOCATION_EVAL_LIST; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? @@ -6110,11 +6101,11 @@ * through the easy dynamic branch. No need to perform more * complex invokations. */ int pc = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame)); *ctxPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { /* * Note: Type BC => ctxPtr->data.eval.path is not used. @@ -6151,11 +6142,11 @@ * Death of SrcInfo reference. */ Tcl_DecrRefCount(ctxPtr->data.eval.path); } - TclStackFree(interp, ctxPtr); + ckfree(ctxPtr); } /* * Now release the lock on the continuation line information, if any, * and restore the caller's settings. @@ -6230,11 +6221,11 @@ * Remove the cmdFrame */ if (eoFramePtr) { iPtr->cmdFramePtr = eoFramePtr->nextPtr; - TclStackFree(interp, eoFramePtr); + ckfree(eoFramePtr); } TclDecrRefCount(listPtr); return result; } Index: generic/tclCkalloc.c ================================================================== --- generic/tclCkalloc.c +++ generic/tclCkalloc.c @@ -1309,14 +1309,10 @@ } allocHead = NULL; Tcl_MutexUnlock(ckallocMutexPtr); #endif - -#if USE_TCLALLOC - TclFinalizeAllocSubsystem(); -#endif } /* * Local Variables: * mode: c Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -2414,11 +2414,11 @@ if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } - TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); + TclCkSmallAlloc(sizeof(ForIterData), iterPtr); iterPtr->cond = objv[2]; iterPtr->body = objv[4]; iterPtr->next = objv[3]; iterPtr->msg = "\n (\"for\" body line %d)"; iterPtr->word = 4; @@ -2442,11 +2442,11 @@ if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL); return TCL_OK; } @@ -2480,11 +2480,11 @@ break; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(iterPtr->msg, Tcl_GetErrorLine(interp))); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } static int ForCondCallback( @@ -2497,15 +2497,15 @@ Tcl_Obj *boolObj = data[1]; int value; if (result != TCL_OK) { Tcl_DecrRefCount(boolObj); - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } else if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) { Tcl_DecrRefCount(boolObj); - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return TCL_ERROR; } Tcl_DecrRefCount(boolObj); if (value) { @@ -2518,11 +2518,11 @@ NULL, NULL); } return TclNREvalObjEx(interp, iterPtr->body, 0, iPtr->cmdFramePtr, iterPtr->word); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } static int ForNextCallback( @@ -2558,11 +2558,11 @@ ForIterData *iterPtr = data[0]; if ((result != TCL_BREAK) && (result != TCL_OK)) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); } return result; } TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL); return result; @@ -2658,11 +2658,11 @@ * The setting up of all of these pointers is moderately messy, but allows * the rest of this code to be simple and for us to use a single memory * allocation for better performance. */ - statePtr = TclStackAlloc(interp, + statePtr = ckalloc( sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); memset(statePtr, 0, sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); @@ -2881,11 +2881,11 @@ } } if (statePtr->resultList != NULL) { TclDecrRefCount(statePtr->resultList); } - TclStackFree(interp, statePtr); + ckfree(statePtr); } /* *---------------------------------------------------------------------- * Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -1337,11 +1337,11 @@ case TCL_LOCATION_BC: { /* * Execution of bytecode. Talk to the BC engine to fill out the frame. */ - CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *fPtr = ckalloc(sizeof(CmdFrame)); *fPtr = *framePtr; /* * Note: @@ -1371,11 +1371,11 @@ Tcl_DecrRefCount(fPtr->data.eval.path); } ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); - TclStackFree(interp, fPtr); + ckfree(fPtr); break; } case TCL_LOCATION_SOURCE: /* @@ -3057,11 +3057,11 @@ case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } if (i > objc-4) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } @@ -3093,11 +3093,11 @@ case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + ckalloc(sizeof(int) * sortInfo.indexc); } /* * Fill the array by parsing each index. We don't know whether * their scale is sensible yet, but we at least perform the @@ -3204,11 +3204,11 @@ * "did not match anything at all" result straight away. [Bug 1374778] */ if (offset > listc-1) { if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); @@ -3529,11 +3529,11 @@ * Cleanup the index list array. */ done: if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } return result; } /* @@ -3823,11 +3823,11 @@ case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + ckalloc(sizeof(int) * sortInfo.indexc); allocatedIndexVector = 1; /* Cannot use indexc field, as it * might be decreased by 1 later. */ } for (j=0 ; jelemCount = i; Tcl_SetObjResult(interp, resultPtr); } done1: - TclStackFree(interp, elementArray); + ckfree(elementArray); done: if (sortInfo.sortMode == SORTMODE_COMMAND) { TclDecrRefCount(sortInfo.compareCmdPtr); TclDecrRefCount(listObj); sortInfo.compareCmdPtr = NULL; } done2: if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } return sortInfo.resultCode; } /* Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -1901,11 +1901,11 @@ /* * Copy the dictionary out into an array; that's the easiest way to * adapt this code... */ - mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); + mapElemv = ckalloc(sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); for (i=2 ; icmdFramePtr; if (splitObjs) { /* * We have to perform the GetSrc and other type dependent handling of @@ -3968,11 +3968,11 @@ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", (overflow ? limit : patternLength), pattern, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } - TclStackFree(interp, ctxPtr); + ckfree(ctxPtr); return result; } /* *---------------------------------------------------------------------- @@ -4748,11 +4748,11 @@ /* * We reuse [for]'s callback, passing a NULL for the 'next' script. */ - TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); + TclCkSmallAlloc(sizeof(ForIterData), iterPtr); iterPtr->cond = objv[1]; iterPtr->body = objv[2]; iterPtr->next = NULL; iterPtr->msg = "\n (\"while\" body line %d)"; iterPtr->word = 2; Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -1680,12 +1680,11 @@ * that are to be used. */ duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); duiPtr->length = numVars; - keyTokenPtrs = TclStackAlloc(interp, - sizeof(Tcl_Token *) * numVars); + keyTokenPtrs = ckalloc(sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { failedUpdateInfoAssembly: ckfree(duiPtr); - TclStackFree(interp, keyTokenPtrs); + ckfree(keyTokenPtrs); return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } bodyTokenPtr = tokenPtr; /* @@ -1784,11 +1783,11 @@ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - TclStackFree(interp, keyTokenPtrs); + ckfree(keyTokenPtrs); envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } int @@ -2602,14 +2601,13 @@ /* * Allocate storage for the varcList and varvList arrays if necessary. */ numLists = (numWords - 2)/2; - varcList = TclStackAlloc(interp, numLists * sizeof(int)); + varcList = ckalloc(numLists * sizeof(int)); memset(varcList, 0, numLists * sizeof(int)); - varvList = (const char ***) TclStackAlloc(interp, - numLists * sizeof(const char **)); + varvList = (const char ***) ckalloc(numLists * sizeof(const char **)); memset((char*) varvList, 0, numLists * sizeof(const char **)); /* * Break up each var list and set the varcList and varvList arrays. Don't * compile the foreach inline if any var name needs substitutions or isn't @@ -2857,12 +2855,12 @@ for (loopIndex = 0; loopIndex < numLists; loopIndex++) { if (varvList[loopIndex] != NULL) { ckfree(varvList[loopIndex]); } } - TclStackFree(interp, (void *)varvList); - TclStackFree(interp, varcList); + ckfree((void *)varvList); + ckfree(varcList); return code; } /* *---------------------------------------------------------------------- @@ -5529,11 +5527,11 @@ /* * Allocate some working space. */ - objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); + objv = ckalloc(numOptionWords * sizeof(Tcl_Obj *)); /* * Scan through the return options. If any are unknown at compile time, * there is no value in bytecompiling. Save the option values known in an * objv array for merging into a return options dictionary. @@ -5553,11 +5551,11 @@ &returnOpts, &code, &level); cleanup: while (--objc >= 0) { TclDecrRefCount(objv[objc]); } - TclStackFree(interp, objv); + ckfree(objv); if (TCL_ERROR == status) { /* * Something was bogus in the return options. Clear the error message, * and report back to the compiler that this must be interpreted at * runtime. @@ -6100,11 +6098,11 @@ /* * An array element, the element name is a simple string: * assemble the corresponding token. */ - elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token)); + elemTokenPtr = ckalloc(sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = elNameChars; elemTokenPtr->numComponents = 0; @@ -6153,11 +6151,11 @@ /* * Make a first token with the extra characters in the first * token. */ - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); + elemTokenPtr = ckalloc(n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = remainingChars; elemTokenPtr->numComponents = 0; @@ -6242,11 +6240,11 @@ if (removedParen) { varTokenPtr[removedParen].size++; } if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); + ckfree(elemTokenPtr); } *localIndexPtr = localIndex; *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); return TCL_OK; Index: generic/tclCompCmdsSZ.c ================================================================== --- generic/tclCompCmdsSZ.c +++ generic/tclCompCmdsSZ.c @@ -735,11 +735,11 @@ if (numArgs == 0) { return TCL_ERROR; } - objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); + objv = ckalloc(/*numArgs*/ numOpts * sizeof(Tcl_Obj *)); for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { objv[objc] = Tcl_NewObj(); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { @@ -768,11 +768,11 @@ cleanup: while (--objc >= 0) { TclDecrRefCount(objv[objc]); } - TclStackFree(interp, objv); + ckfree(objv); if (/*toSubst == NULL*/ code != TCL_OK) { return TCL_ERROR; } SetLineInformation(numArgs); @@ -1429,12 +1429,12 @@ * Generate a test for each arm. */ contFixIndex = -1; contFixCount = 0; - fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens); - fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens); + fixupArray = ckalloc(sizeof(JumpFixup) * numBodyTokens); + fixupTargetArray = ckalloc(sizeof(int) * numBodyTokens); memset(fixupTargetArray, 0, numBodyTokens * sizeof(int)); fixupCount = 0; foundDefault = 0; for (i=0 ; icurrStackDepth = savedStackDepth + 1; } /* @@ -1692,11 +1692,11 @@ */ jtPtr = ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); + finalFixups = ckalloc(sizeof(int) * (numBodyTokens/2)); foundDefault = 0; mustGenerate = 1; /* * Next, issue the instruction to do the jump, together with what we want @@ -1831,11 +1831,11 @@ /* * Clean up all our temporary space and return. */ - TclStackFree(interp, finalFixups); + ckfree(finalFixups); envPtr->currStackDepth = savedStackDepth + 1; } /* *---------------------------------------------------------------------- @@ -2137,16 +2137,16 @@ */ numHandlers = numWords >> 2; numWords -= numHandlers * 4; if (numHandlers > 0) { - handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers); - matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers); + handlerTokens = ckalloc(sizeof(Tcl_Token*)*numHandlers); + matchClauses = ckalloc(sizeof(Tcl_Obj *) * numHandlers); memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers); - matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers); - resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); - optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); + matchCodes = ckalloc(sizeof(int) * numHandlers); + resultVarIndices = ckalloc(sizeof(int) * numHandlers); + optionVarIndices = ckalloc(sizeof(int) * numHandlers); for (i=0 ; icurrStackDepth = savedStackDepth + 1; return TCL_OK; } static int @@ -2537,12 +2537,12 @@ if (numHandlers) { /* * Slight overallocation, but reduces size of this function. */ - addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); + addrsToFix = ckalloc(sizeof(int)*numHandlers); + forwardsToFix = ckalloc(sizeof(int)*numHandlers); for (i=0 ; itype = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = elNameChars; elemTokenPtr->numComponents = 0; @@ -3164,11 +3164,11 @@ /* * Make a first token with the extra characters in the first * token. */ - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); + elemTokenPtr = ckalloc(n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = remainingChars; elemTokenPtr->numComponents = 0; @@ -3252,11 +3252,11 @@ if (removedParen) { varTokenPtr[removedParen].size++; } if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); + ckfree(elemTokenPtr); } *localIndexPtr = localIndex; *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); return TCL_OK; Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -915,11 +915,11 @@ scanned = tokenPtr->size; break; case SCRIPT: { Tcl_Parse *nestedPtr = - TclStackAlloc(interp, sizeof(Tcl_Parse)); + ckalloc(sizeof(Tcl_Parse)); tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->start = start; tokenPtr->numComponents = 0; @@ -950,11 +950,11 @@ code = TCL_ERROR; errCode = "UNBALANCED"; break; } } - TclStackFree(interp, nestedPtr); + ckfree(nestedPtr); end = start; start = tokenPtr->start; scanned = end - start; tokenPtr->size = scanned; parsePtr->numTokens++; @@ -1833,11 +1833,11 @@ { int code; OpNode *opTree = NULL; /* Will point to the tree of operators. */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */ - Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *exprParsePtr = ckalloc(sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions. */ if (numBytes < 0) { numBytes = (start ? strlen(start) : 0); } @@ -1855,11 +1855,11 @@ parsePtr->term = exprParsePtr->term; parsePtr->errorType = exprParsePtr->errorType; } Tcl_FreeParse(exprParsePtr); - TclStackFree(interp, exprParsePtr); + ckfree(exprParsePtr); ckfree(opTree); return code; } /* @@ -2125,11 +2125,11 @@ int optimize) /* 0 for one-off expressions. */ { OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions */ int code = ParseExpr(interp, script, numBytes, &opTree, litList, funcList, parsePtr, 0 /* parseOnly */); @@ -2153,11 +2153,11 @@ } else { TclCompileSyntaxError(interp, envPtr); } Tcl_FreeParse(parsePtr); - TclStackFree(interp, parsePtr); + ckfree(parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree(opTree); } @@ -2196,19 +2196,19 @@ * Note we are compiling an expression with literal arguments. This means * there can be no [info frame] calls when we execute the resulting * bytecode, so there's no need to tend to TIP 280 issues. */ - envPtr = TclStackAlloc(interp, sizeof(CompileEnv)); + envPtr = ckalloc(sizeof(CompileEnv)); TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0); CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); Tcl_IncrRefCount(byteCodeObj); TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); - TclStackFree(interp, envPtr); + ckfree(envPtr); byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); return code; @@ -2261,28 +2261,28 @@ if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; switch (nodePtr->lexeme) { case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; jumpPtr->depth = envPtr->currStackDepth; convert = 1; break; case AND: case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; jumpPtr->depth = envPtr->currStackDepth; break; } @@ -2384,14 +2384,14 @@ jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); break; case AND: case OR: CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) @@ -2411,17 +2411,17 @@ 127); convert = 0; envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); convert = 0; break; @@ -2621,13 +2621,12 @@ if (objc < 3) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } else { TclOpCmdClientData *occdPtr = clientData; - Tcl_Obj **litObjv = TclStackAlloc(interp, - 2 * (objc-2) * sizeof(Tcl_Obj *)); - OpNode *nodes = TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode)); + Tcl_Obj **litObjv = ckalloc(2 * (objc-2) * sizeof(Tcl_Obj *)); + OpNode *nodes = ckalloc(2 * (objc-2) * sizeof(OpNode)); unsigned char lexeme; int i, lastAnd = 1; Tcl_Obj *const *litObjPtrPtr = litObjv; ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL); @@ -2663,12 +2662,12 @@ nodes[0].right = lastAnd; nodes[lastAnd].p.parent = 0; code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr); - TclStackFree(interp, nodes); - TclStackFree(interp, litObjv); + ckfree(nodes); + ckfree(litObjv); } return code; } /* @@ -2750,11 +2749,11 @@ Tcl_DecrRefCount(litObjv[decrMe]); return code; } else { Tcl_Obj *const *litObjv = objv + 1; - OpNode *nodes = TclStackAlloc(interp, (objc-1) * sizeof(OpNode)); + OpNode *nodes = ckalloc((objc-1) * sizeof(OpNode)); int i, lastOp = OT_LITERAL; nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; if (lexeme == EXPON) { @@ -2783,11 +2782,11 @@ nodes[0].right = lastOp; nodes[lastOp].p.parent = 0; code = ExecConstantExprTree(interp, nodes, 0, &litObjv); - TclStackFree(interp, nodes); + ckfree(nodes); return code; } } /* Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -1313,11 +1313,11 @@ * to that context. Note that the context can be byte code execution. * In that case we have to fill out the missing pieces (line, path, * ...) which may make change the type as well. */ - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame)); int pc = 0; *ctxPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { /* @@ -1366,11 +1366,11 @@ Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); } } } - TclStackFree(interp, ctxPtr); + ckfree(ctxPtr); } envPtr->extCmdMapPtr->start = envPtr->line; /* @@ -1572,11 +1572,11 @@ int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex; Tcl_DString ds; /* TIP #280 */ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat, cmdLine, *clNext; - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); Tcl_DStringInit(&ds); if (numBytes < 0) { numBytes = strlen(script); @@ -2010,11 +2010,11 @@ if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } envPtr->numSrcBytes = p - script; - TclStackFree(interp, parsePtr); + ckfree(parsePtr); Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -2397,18 +2397,18 @@ if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); return TCL_ERROR; } - searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); + searchPtr = ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj, &done) != TCL_OK) { - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return TCL_ERROR; } if (done) { - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return TCL_OK; } TclListObjGetElements(NULL, objv[1], &varc, &varv); keyVarObj = varv[0]; valueVarObj = varv[1]; @@ -2454,11 +2454,11 @@ error: TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return TCL_ERROR; } static int DictForLoopCallback( @@ -2536,11 +2536,11 @@ done: TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return result; } /* *---------------------------------------------------------------------- @@ -2588,24 +2588,24 @@ if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); return TCL_ERROR; } - storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); + storagePtr = ckalloc(sizeof(DictMapStorage)); if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj, &valueObj, &done) != TCL_OK) { - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return TCL_ERROR; } if (done) { /* * Note that this exit leaves an empty value in the result (due to * command calling conventions) but that is OK since an empty value is * an empty dictionary. */ - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return TCL_OK; } TclNewObj(storagePtr->accumulatorObj); TclListObjGetElements(NULL, objv[1], &varc, &varv); storagePtr->keyVarObj = varv[0]; @@ -2657,11 +2657,11 @@ TclDecrRefCount(storagePtr->keyVarObj); TclDecrRefCount(storagePtr->valueVarObj); TclDecrRefCount(storagePtr->scriptObj); TclDecrRefCount(storagePtr->accumulatorObj); Tcl_DictObjDone(&storagePtr->search); - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return TCL_ERROR; } static int DictMapLoopCallback( @@ -2747,11 +2747,11 @@ TclDecrRefCount(storagePtr->keyVarObj); TclDecrRefCount(storagePtr->valueVarObj); TclDecrRefCount(storagePtr->scriptObj); TclDecrRefCount(storagePtr->accumulatorObj); Tcl_DictObjDone(&storagePtr->search); - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return result; } /* *---------------------------------------------------------------------- Index: generic/tclEvent.c ================================================================== --- generic/tclEvent.c +++ generic/tclEvent.c @@ -1041,15 +1041,13 @@ * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ + TclInitAlloc(); /* Process wide allocator init */ TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ -#if USE_TCLALLOC - TclInitAlloc(); /* Process wide mutex init */ -#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif TclpInitPlatform(); /* Creates signal handler(s) */ @@ -1218,18 +1216,10 @@ * alive at this moment. */ TclFinalizeSynchronization(); - /* - * Close down the thread-specific object allocator. - */ - -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAlloc(); -#endif - /* * We defer unloading of packages until very late to avoid memory access * issues. Both exit callbacks and synchronization variables may be stored * in packages. * @@ -1249,10 +1239,18 @@ /* * At this point, there should no longer be any ckalloc'ed memory. */ TclFinalizeMemorySubsystem(); + + /* + * Close down the thread-specific object allocator. + */ + + TclFinalizeAlloc(); + + alreadyFinalized: TclFinalizeLock(); } Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -172,34 +172,36 @@ */ typedef struct TEBCdata { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ + Tcl_Obj **tosPtr; const unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ + unsigned long catchDepth; /* this level: they record the state when a */ int cleanup; /* new codePtr was received for NR */ Tcl_Obj *auxObjList; /* execution. */ int checkInterp; + unsigned int capacity; CmdFrame cmdFrame; void *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ } TEBCdata; #define TEBC_YIELD() \ do { \ - esPtr->tosPtr = tosPtr; \ + TD->tosPtr = tosPtr; \ TD->pc = pc; \ TD->cleanup = cleanup; \ TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \ } while (0) #define TEBC_DATA_DIG() \ do { \ pc = TD->pc; \ cleanup = TD->cleanup; \ - tosPtr = esPtr->tosPtr; \ + tosPtr = TD->tosPtr; \ } while (0) #define PUSH_TAUX_OBJ(objPtr) \ do { \ objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ @@ -313,24 +315,10 @@ } else { \ goto cleanupV; \ } \ } while (0) -/* - * Macros used to cache often-referenced Tcl evaluation stack information - * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() - * pair must surround any call inside TclNRExecuteByteCode (and a few other - * procedures that use this scheme) that could result in a recursive call - * to TclNRExecuteByteCode. - */ - -#define CACHE_STACK_INFO() \ - checkInterp = 1 - -#define DECACHE_STACK_INFO() \ - esPtr->tosPtr = tosPtr - /* * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT * increments the object's ref count since it makes the stack have another * reference pointing to the object. However, POP_OBJECT does not decrement * the ref count. This is because the stack may hold the only reference to the @@ -701,11 +689,10 @@ static void ValidatePcAndStackTop(ByteCode *codePtr, const unsigned char *pc, int stackTop, int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, @@ -717,20 +704,14 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, const unsigned char **pcBeg); -static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, - int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int OFFSET(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); -/* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; static Tcl_NRPostProc TEBCresume; @@ -863,29 +844,20 @@ * environment is being created. */ int size) /* The initial stack size, in number of words * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = ckalloc(sizeof(ExecStack) - + (size_t) (size-1) * sizeof(Tcl_Obj *)); - eePtr->execStackPtr = esPtr; TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; eePtr->corPtr = NULL; eePtr->rewind = 0; - esPtr->prevPtr = NULL; - esPtr->nextPtr = NULL; - esPtr->markerPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; - Tcl_MutexLock(&execMutex); if (!execInitialized) { TclInitAuxDataTypeTable(); InitByteCodeExecution(interp); execInitialized = 1; @@ -910,48 +882,20 @@ * stack) is freed. * *---------------------------------------------------------------------- */ -static void -DeleteExecStack( - ExecStack *esPtr) -{ - if (esPtr->markerPtr && !cachedInExit) { - Tcl_Panic("freeing an execStack which is still in use"); - } - - if (esPtr->prevPtr) { - esPtr->prevPtr->nextPtr = esPtr->nextPtr; - } - if (esPtr->nextPtr) { - esPtr->nextPtr->prevPtr = esPtr->prevPtr; - } - ckfree(esPtr); -} - void TclDeleteExecEnv( ExecEnv *eePtr) /* Execution environment to free. */ { - ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; - cachedInExit = TclInExit(); /* * Delete all stacks in this exec env. */ - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } - while (esPtr) { - tmpPtr = esPtr; - esPtr = tmpPtr->prevPtr; - DeleteExecStack(tmpPtr); - } - TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); if (eePtr->callbackPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); } @@ -985,355 +929,10 @@ Tcl_MutexLock(&execMutex); execInitialized = 0; Tcl_MutexUnlock(&execMutex); TclFinalizeAuxDataTypeTable(); } - -/* - * Auxiliary code to insure that GrowEvaluationStack always returns correctly - * aligned memory. - * - * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN - * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a - * multiple of the wordsize 'sizeof(Tcl_Obj *)'. - */ - -#define WALLOCALIGN \ - (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) - -/* - * OFFSET computes how many words have to be skipped until the next aligned - * word. Note that we are only interested in the low order bits of ptr, so - * that any possible information loss in PTR2INT is of no consequence. - */ - -static inline int -OFFSET( - void *ptr) -{ - int mask = TCL_ALLOCALIGN-1; - int base = PTR2INT(ptr) & mask; - return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); -} - -/* - * Given a marker, compute where the following aligned memory starts. - */ - -#define MEMSTART(markerPtr) \ - ((markerPtr) + OFFSET(markerPtr)) - -/* - *---------------------------------------------------------------------- - * - * GrowEvaluationStack -- - * - * This procedure grows a Tcl evaluation stack stored in an ExecEnv, - * copying over the words since the last mark if so requested. A mark is - * set at the beginning of the new area when no copying is requested. - * - * Results: - * Returns a pointer to the first usable word in the (possibly) grown - * stack. - * - * Side effects: - * The size of the evaluation stack may be grown, a marker is set - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj ** -GrowEvaluationStack( - ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation - * stack to enlarge. */ - int growth, /* How much larger than the current used - * size. */ - int move) /* 1 if move words since last marker. */ -{ - ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; - int newBytes, newElems, currElems; - int needed = growth - (esPtr->endPtr - esPtr->tosPtr); - Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; - int moveWords = 0; - - if (move) { - if (!markerPtr) { - Tcl_Panic("STACK: Reallocating with no previous alloc"); - } - if (needed <= 0) { - return MEMSTART(markerPtr); - } - } else { -#ifndef PURIFY - Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; - int offset = OFFSET(tmpMarkerPtr); - - if (needed + offset < 0) { - /* - * Put a marker pointing to the previous marker in this stack, and - * store it in esPtr as the current marker. Return a pointer to - * the start of aligned memory. - */ - - esPtr->markerPtr = tmpMarkerPtr; - memStart = tmpMarkerPtr + offset; - esPtr->tosPtr = memStart - 1; - *esPtr->markerPtr = (Tcl_Obj *) markerPtr; - return memStart; - } -#endif - } - - /* - * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements: add one for - * the marker, (WALLOCALIGN-1) for the maximal possible offset. - */ - - if (move) { - moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; - } - needed = growth + moveWords + WALLOCALIGN; - - - /* - * Check if there is enough room in the next stack (if there is one, it - * should be both empty and the last one!) - */ - - if (esPtr->nextPtr) { - oldPtr = esPtr; - esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { - Tcl_Panic("STACK: Stack after current is in use"); - } - if (esPtr->nextPtr) { - Tcl_Panic("STACK: Stack after current is not last"); - } - if (needed <= currElems) { - goto newStackReady; - } - DeleteExecStack(esPtr); - esPtr = oldPtr; - } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - } - - /* - * We need to allocate a new stack! It needs to store 'growth' words, - * including the elements to be copied over and the new marker. - */ - -#ifndef PURIFY - newElems = 2*currElems; - while (needed > newElems) { - newElems *= 2; - } -#else - newElems = needed; -#endif - - newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); - - oldPtr = esPtr; - esPtr = ckalloc(newBytes); - - oldPtr->nextPtr = esPtr; - esPtr->prevPtr = oldPtr; - esPtr->nextPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[newElems-1]; - - newStackReady: - eePtr->execStackPtr = esPtr; - - /* - * Store a NULL marker at the beginning of the stack, to indicate that - * this is the first marker in this stack and that rewinding to here - * should actually be a return to the previous stack. - */ - - esPtr->stackWords[0] = NULL; - esPtr->markerPtr = &esPtr->stackWords[0]; - memStart = MEMSTART(esPtr->markerPtr); - esPtr->tosPtr = memStart - 1; - - if (move) { - memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *)); - esPtr->tosPtr += moveWords; - oldPtr->markerPtr = (Tcl_Obj **) *markerPtr; - oldPtr->tosPtr = markerPtr-1; - } - - /* - * Free the old stack if it is now unused. - */ - - if (!oldPtr->markerPtr) { - DeleteExecStack(oldPtr); - } - - return memStart; -} - -/* - *-------------------------------------------------------------- - * - * TclStackAlloc, TclStackRealloc, TclStackFree -- - * - * Allocate memory from the execution stack; it has to be returned later - * with a call to TclStackFree. - * - * Results: - * A pointer to the first byte allocated, or panics if the allocation did - * not succeed. - * - * Side effects: - * The execution stack may be grown. - * - *-------------------------------------------------------------- - */ - -static Tcl_Obj ** -StackAllocWords( - Tcl_Interp *interp, - int numWords) -{ - /* - * Note that GrowEvaluationStack sets a marker in the stack. This marker - * is read when rewinding, e.g., by TclStackFree. - */ - - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0); - - eePtr->execStackPtr->tosPtr += numWords; - return resPtr; -} - -static Tcl_Obj ** -StackReallocWords( - Tcl_Interp *interp, - int numWords) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1); - - eePtr->execStackPtr->tosPtr += numWords; - return resPtr; -} - -void -TclStackFree( - Tcl_Interp *interp, - void *freePtr) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr, *marker; - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree((char *) freePtr); - return; - } - - /* - * Rewind the stack to the previous marker position. The current marker, - * as set in the last call to GrowEvaluationStack, contains a pointer to - * the previous marker. - */ - - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; - marker = *markerPtr; - - if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) { - Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?", - freePtr, MEMSTART(markerPtr)); - } - - esPtr->tosPtr = markerPtr - 1; - esPtr->markerPtr = (Tcl_Obj **) marker; - if (marker) { - return; - } - - /* - * Return to previous active stack. Note that repeated expansions or - * reallocs could have generated several unused intervening stacks: free - * them too. - */ - - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } - esPtr->tosPtr = &esPtr->stackWords[-1]; - while (esPtr->prevPtr) { - ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { - DeleteExecStack(tmpPtr); - } else { - break; - } - } - if (esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->prevPtr; -#ifdef PURIFY - eePtr->execStackPtr->nextPtr = NULL; - DeleteExecStack(esPtr); -#endif - } else { - eePtr->execStackPtr = esPtr; - } -} - -void * -TclStackAlloc( - Tcl_Interp *interp, - int numBytes) -{ - Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) ckalloc(numBytes); - } - - return (void *) StackAllocWords(interp, numWords); -} - -void * -TclStackRealloc( - Tcl_Interp *interp, - void *ptr, - int numBytes) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr; - int numWords; - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) ckrealloc((char *) ptr, numBytes); - } - - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; - - if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) { - Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?"); - } - - numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - return (void *) StackReallocWords(interp, numWords); -} /* *-------------------------------------------------------------- * * Tcl_ExprObj -- @@ -1733,11 +1332,11 @@ return codePtr; } eclPtr = Tcl_GetHashValue(hePtr); redo = 0; - ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + ctxCopyPtr = ckalloc(sizeof(CmdFrame)); *ctxCopyPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { /* * Note: Type BC => ctx.data.eval.path is not used. @@ -1771,11 +1370,11 @@ && (eclPtr->start != ctxCopyPtr->line[word])) || ((eclPtr->type == TCL_LOCATION_BC) && (ctxCopyPtr->type == TCL_LOCATION_SOURCE)); } - TclStackFree(interp, ctxCopyPtr); + ckfree(ctxCopyPtr); if (!redo) { return codePtr; } } } @@ -1945,26 +1544,36 @@ * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ #define bcFramePtr (&TD->cmdFrame) -#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1])) -#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) -#define esPtr (iPtr->execEnvPtr->execStackPtr) +#define catchStack (TD->stack) +#define initTosPtr ((Tcl_Obj **) &TD->stack[codePtr->maxExceptDepth - 1]) + +/* + * The execution uses a unified stack: first a TEBCdata, immediately + * above it the catch stack, then the execution stack. + * + * Make sure the catch stack is large enough to hold the maximum number of + * catch commands that could ever be executing at the same time (this will + * be no more than the exception range array's depth). Make sure the + * execution stack is large enough to execute this ByteCode. + */ + +// FIXME! The "+1" should not be necessary, temporary until we fix BC issues + +#define capacity2size(cap) \ + (offsetof(TEBCdata, stack) + sizeof(void *)*(cap + codePtr->maxExceptDepth + 1)) int TclNRExecuteByteCode( Tcl_Interp *interp, /* Token for command interpreter. */ ByteCode *codePtr) /* The bytecode sequence to interpret. */ { Interp *iPtr = (Interp *) interp; TEBCdata *TD; - int size = sizeof(TEBCdata) - 1 - + (codePtr->maxStackDepth + codePtr->maxExceptDepth) - * sizeof(void *); - int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - + if (iPtr->execEnvPtr->rewind) { return TCL_ERROR; } codePtr->refCount++; @@ -1979,19 +1588,20 @@ * catch commands that could ever be executing at the same time (this will * be no more than the exception range array's depth). Make sure the * execution stack is large enough to execute this ByteCode. */ - TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); - esPtr->tosPtr = initTosPtr; + TD = ckalloc(capacity2size(codePtr->maxStackDepth)); TD->codePtr = codePtr; - TD->pc = codePtr->codeStart; - TD->catchTop = initCatchTop; + TD->tosPtr = initTosPtr; + TD->pc = codePtr->codeStart; + TD->catchDepth = -1; TD->cleanup = 0; TD->auxObjList = NULL; TD->checkInterp = 0; + TD->capacity = codePtr->maxStackDepth; /* * TIP #280: Initialize the frame. Do not push it yet: it will be pushed * every time that we call out from this TD, popped when we return to it. */ @@ -2071,15 +1681,15 @@ * used too frequently */ TEBCdata *TD = data[0]; #define auxObjList (TD->auxObjList) -#define catchTop (TD->catchTop) +#define catchDepth (TD->catchDepth) #define codePtr (TD->codePtr) #define checkInterp (TD->checkInterp) - /* Indicates when a check of interp readyness is - * necessary. Set by CACHE_STACK_INFO() */ + /* Indicates when a check of interp readyness + * is necessary. Set by checkInterp = 1 */ /* * Globals: variables that store state, must remain valid at all times. */ @@ -2138,11 +1748,11 @@ if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - CACHE_STACK_INFO(); + checkInterp = 1; if (result == TCL_OK) { #ifndef TCL_COMPILE_DEBUG if (*pc == INST_POP) { NEXT_INST_V(1, cleanup, 0); } @@ -2258,33 +1868,32 @@ * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { - DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); if (result == TCL_ERROR) { - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } } if (TclCanceled(iPtr)) { if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } } if (TclLimitReady(iPtr->limit)) { if (Tcl_LimitCheck(interp) == TCL_ERROR) { - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } } - CACHE_STACK_INFO(); + checkInterp = 1; } /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale @@ -2698,11 +2307,11 @@ PUSH_TAUX_OBJ(objPtr); NEXT_INST_F(1, 0, 0); case INST_EXPAND_STKTOP: { int i; - ptrdiff_t moved; + unsigned int reqWords; /* * Make sure that the element at stackTop is a list; if not, just * leave with an error. Note that the element from the expand list * will be removed at checkForCatch. @@ -2712,35 +2321,35 @@ if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); goto gotError; } - (void) POP_OBJECT(); /* * Make sure there is enough room in the stack to expand this list * *and* process the rest of the command (at least up to the next * argument expansion or command end). The operand is the current * stack depth, as seen by the compiler. */ - length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); - DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) TD; - if (moved) { - /* - * Change the global data to point to the new stack: move the - * TEBCdataPtr TD, recompute the position of every other - * stack-allocated parameter, update the stack pointers. - */ - - esPtr = iPtr->execEnvPtr->execStackPtr; - TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); - - catchTop += moved; - tosPtr += moved; + reqWords = + /* how many were needed originally */ + codePtr->maxStackDepth + /* plus how many we already consumed in previous expansions */ + + (CURR_DEPTH - TclGetInt4AtPtr(pc+1)) + /* plus how many are needed for this expansion */ + + objc - 1; + + (void) POP_OBJECT(); + if (reqWords > TD->capacity) { + ptrdiff_t depth; + unsigned int size = capacity2size(reqWords); + + depth = tosPtr - initTosPtr; + TD = ckrealloc(TD, size); + TD->capacity = reqWords; + tosPtr = initTosPtr + depth; } /* * Expand the list at stacktop onto the stack; free the list. Knowing * that it has a freeIntRepProc we use Tcl_DecrRefCount(). @@ -2757,13 +2366,12 @@ case INST_EXPR_STK: { ByteCode *newCodePtr; bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; - DECACHE_STACK_INFO(); newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); - CACHE_STACK_INFO(); + checkInterp = 1; cleanup = 1; pc++; TEBC_YIELD(); return TclNRExecuteByteCode(interp, newCodePtr); } @@ -2844,12 +2452,10 @@ if (iPtr->flags & INTERP_DEBUG_FRAME) { TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, codePtr, bcFramePtr, pc - codePtr->codeStart); } - DECACHE_STACK_INFO(); - pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL); @@ -2992,18 +2598,17 @@ codePtr, bcFramePtr, pc - codePtr->codeStart); } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; iPtr->ensembleRewrite.numInsertedObjs = 1; - DECACHE_STACK_INFO(); pc += 6; TEBC_YIELD(); TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); TclSkipTailcall(interp); return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN); - + /* * ----------------------------------------------------------------- * Start of INST_LOAD instructions. * * WARNING: more 'goto' here than your doctor recommended! The different @@ -3134,14 +2739,13 @@ /* * There are either errors or the variable is traced: call * TclPtrGetVar to process fully. */ - DECACHE_STACK_INFO(); objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; if (!objResultPtr) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -3381,14 +2985,13 @@ cleanup = 1; arrayPtr = NULL; part1Ptr = part2Ptr = NULL; doCallPtrSetVar: - DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; if (!objResultPtr) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } #ifndef TCL_COMPILE_DEBUG @@ -3645,14 +3248,13 @@ O2S(Tcl_GetObjResult(interp)))); goto gotError; } Tcl_DecrRefCount(incrPtr); } else { - DECACHE_STACK_INFO(); objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -3680,14 +3282,13 @@ while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (ReadTraced(varPtr)) { - DECACHE_STACK_INFO(); TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, TCL_TRACE_READS, 0, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, NULL); varPtr = NULL; } } @@ -3716,14 +3317,13 @@ } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", 0, 1, arrayPtr, opnd); if (varPtr) { if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - DECACHE_STACK_INFO(); TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr, TCL_TRACE_READS, 0, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; } if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); varPtr = NULL; } @@ -3749,14 +3349,13 @@ doExistStk: varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access", /*createPart1*/0, /*createPart2*/1, &arrayPtr); if (varPtr) { if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - DECACHE_STACK_INFO(); TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr, TCL_TRACE_READS, 0, -1); - CACHE_STACK_INFO(); + checkInterp = 1; } if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); varPtr = NULL; } @@ -3796,16 +3395,15 @@ varPtr->value.objPtr = NULL; NEXT_INST_F(6, 0, 0); } slowUnsetScalar: - DECACHE_STACK_INFO(); if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, opnd) != TCL_OK && flags) { goto errorInUnset; } - CACHE_STACK_INFO(); + checkInterp = 1; NEXT_INST_F(6, 0, 0); case INST_UNSET_ARRAY: flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; opnd = TclGetUInt4AtPtr(pc+2); @@ -3838,11 +3436,10 @@ NEXT_INST_F(6, 1, 0); } } slowUnsetArray: - DECACHE_STACK_INFO(); varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", 0, 0, arrayPtr, opnd); if (!varPtr) { if (flags & TCL_LEAVE_ERR_MSG) { goto errorInUnset; @@ -3849,11 +3446,11 @@ } } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr, flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { goto errorInUnset; } - CACHE_STACK_INFO(); + checkInterp = 1; NEXT_INST_F(6, 1, 0); case INST_UNSET_ARRAY_STK: flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; cleanup = 2; @@ -3869,20 +3466,19 @@ part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); doUnsetStk: - DECACHE_STACK_INFO(); if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { goto errorInUnset; } - CACHE_STACK_INFO(); + checkInterp = 1; NEXT_INST_V(2, cleanup, 0); errorInUnset: - CACHE_STACK_INFO(); + checkInterp = 1; TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; /* * This is really an unset operation these days. Do not issue. @@ -3899,13 +3495,12 @@ if (!TclIsVarUndefined(varPtr)) { TclDecrRefCount(varPtr->value.objPtr); } varPtr->value.objPtr = NULL; } else { - DECACHE_STACK_INFO(); TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; } NEXT_INST_F(5, 0, 0); } /* @@ -3935,15 +3530,13 @@ varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/0, /*createPart2*/0, &arrayPtr); doArrayExists: if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - DECACHE_STACK_INFO(); result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); - CACHE_STACK_INFO(); if (result == TCL_ERROR) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -4240,22 +3833,20 @@ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } if (*pc == INST_LOR) { iResult = (i1 || i2); @@ -5350,24 +4941,22 @@ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } /* * Check for common, simple case. @@ -5421,15 +5010,14 @@ case INST_RSHIFT: if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #if 0 - DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; #endif goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); @@ -5469,15 +5057,14 @@ case INST_LSHIFT: if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #if 0 - DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; #endif goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); @@ -5492,14 +5079,13 @@ */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); #if 0 - DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; #endif goto gotError; } else { int shift = (int) l2; @@ -5578,13 +5164,12 @@ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } #ifdef ACCEPT_NAN if (type1 == TCL_NUMBER_NAN) { @@ -5599,13 +5184,12 @@ if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) || IsErroringNaNType(type2)) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } #ifdef ACCEPT_NAN if (type2 == TCL_NUMBER_NAN) { @@ -5748,13 +5332,12 @@ /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } /* TODO: Consider peephole opt. */ objResultPtr = TCONST(!b); NEXT_INST_F(1, 1, 1); @@ -5768,13 +5351,12 @@ * ... ~$NonInteger => raise an error. */ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } if (type1 == TCL_NUMBER_LONG) { l1 = *((const long *) ptr1); if (Tcl_IsShared(valuePtr)) { @@ -5795,13 +5377,12 @@ valuePtr = OBJ_AT_TOS; if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ @@ -5841,13 +5422,12 @@ * ... +$NonNumeric => raise an error. */ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } /* ... TryConvertToNumeric($NonNumeric) is acceptable */ TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); @@ -5859,23 +5439,21 @@ * ... +$NonNumeric => raise an error. */ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; } else { /* * Numeric conversion of NaN -> error. */ TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", O2S(objResultPtr))); - DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); - CACHE_STACK_INFO(); + checkInterp = 1; } goto gotError; } /* @@ -5916,23 +5494,21 @@ * ----------------------------------------------------------------- */ case INST_BREAK: /* - DECACHE_STACK_INFO(); Tcl_ResetResult(interp); - CACHE_STACK_INFO(); + checkInterp = 1; */ result = TCL_BREAK; cleanup = 0; goto processExceptionReturn; case INST_CONTINUE: /* - DECACHE_STACK_INFO(); Tcl_ResetResult(interp); - CACHE_STACK_INFO(); + checkInterp = 1; */ result = TCL_CONTINUE; cleanup = 0; goto processExceptionReturn; @@ -6061,21 +5637,20 @@ } varPtr->value.objPtr = valuePtr; Tcl_IncrRefCount(valuePtr); } } else { - DECACHE_STACK_INFO(); if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ - CACHE_STACK_INFO(); + checkInterp = 1; TRACE_WITH_OBJ(( "%u => ERROR init. index temp %d: ", opnd,varIndex), Tcl_GetObjResult(interp)); TclDecrRefCount(listPtr); goto gotError; } - CACHE_STACK_INFO(); + checkInterp = 1; } valIndex++; } TclDecrRefCount(listPtr); listTmpIndex++; @@ -6103,23 +5678,22 @@ * Record start of the catch command with exception range index equal * to the operand. Push the current stack depth onto the special catch * stack. */ - *(++catchTop) = CURR_DEPTH; - TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), + catchStack[++catchDepth] = INT2PTR(CURR_DEPTH); + TRACE(("%u => catchDepth=%d, stackTop=%d\n", + TclGetUInt4AtPtr(pc+1), (int) (catchDepth), (int) CURR_DEPTH)); NEXT_INST_F(5, 0, 0); case INST_END_CATCH: - catchTop--; - DECACHE_STACK_INFO(); + catchDepth--; Tcl_ResetResult(interp); - CACHE_STACK_INFO(); + checkInterp = 1; result = TCL_OK; - TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); + TRACE(("=> catchDepth=%d\n", (int) (catchDepth))); NEXT_INST_F(1, 0, 0); case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); TRACE_WITH_OBJ(("=> "), objResultPtr); @@ -6137,13 +5711,12 @@ TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); case INST_PUSH_RETURN_OPTIONS: - DECACHE_STACK_INFO(); objResultPtr = Tcl_GetReturnOptions(interp, result); - CACHE_STACK_INFO(); + checkInterp = 1; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_RETURN_CODE_BRANCH: { int code; @@ -6216,17 +5789,16 @@ } if (objResultPtr) { TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd+1, 1); } - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "key \"%s\" not known in dictionary", TclGetString(OBJ_AT_TOS))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); + checkInterp = 1; TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); } else { if (*pc == INST_DICT_EXISTS) { dictNotExists: objResultPtr = TCONST(0); @@ -6252,13 +5824,12 @@ } TRACE(("%u %u => ", opnd, opnd2)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { - DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); - CACHE_STACK_INFO(); + checkInterp = 1; } if (dictPtr == NULL) { TclNewObj(dictPtr); allocateDict = 1; } else { @@ -6326,14 +5897,13 @@ varPtr->value.objPtr = dictPtr; } objResultPtr = dictPtr; } else { Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd2); - CACHE_STACK_INFO(); + checkInterp = 1; TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -6356,13 +5926,12 @@ } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { - DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; } if (dictPtr == NULL) { TclNewObj(dictPtr); allocateDict = 1; } else { @@ -6462,14 +6031,13 @@ varPtr->value.objPtr = dictPtr; } objResultPtr = dictPtr; } else { Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -6567,14 +6135,13 @@ } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { - DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; if (dictPtr == NULL) { goto gotError; } } if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, @@ -6591,22 +6158,21 @@ } varPtr = LOCAL(duiPtr->varIndices[i]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - DECACHE_STACK_INFO(); if (valuePtr == NULL) { TclObjUnsetVar2(interp, localName(iPtr->varFramePtr, duiPtr->varIndices[i]), NULL, 0); } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } - CACHE_STACK_INFO(); + checkInterp = 1; } NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); @@ -6618,13 +6184,12 @@ } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { - DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; } if (dictPtr == NULL) { NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK @@ -6646,14 +6211,13 @@ var2Ptr = var2Ptr->value.linkPtr; } if (TclIsVarDirectReadable(var2Ptr)) { valuePtr = var2Ptr->value.objPtr; } else { - DECACHE_STACK_INFO(); valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, duiPtr->varIndices[i]); - CACHE_STACK_INFO(); + checkInterp = 1; } if (valuePtr == NULL) { Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); } else if (dictPtr == valuePtr) { Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], @@ -6665,14 +6229,13 @@ if (TclIsVarDirectWritable(varPtr)) { Tcl_IncrRefCount(dictPtr); TclDecrRefCount(varPtr->value.objPtr); varPtr->value.objPtr = dictPtr; } else { - DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; if (objResultPtr == NULL) { if (allocdict) { TclDecrRefCount(dictPtr); } goto gotError; @@ -6713,14 +6276,12 @@ if (varPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); TclDecrRefCount(keysPtr); goto gotError; } - DECACHE_STACK_INFO(); result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, objc, objv, keysPtr); - CACHE_STACK_INFO(); TclDecrRefCount(keysPtr); if (result != TCL_OK) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6739,14 +6300,12 @@ goto gotError; } while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - DECACHE_STACK_INFO(); result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, objc, objv, keysPtr); - CACHE_STACK_INFO(); if (result != TCL_OK) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6856,28 +6415,26 @@ * Division by zero in an expression. Control only reaches this point * by "goto divideByZero". */ divideByZero: - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + Tcl_SetResult(interp, "divide by zero", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; /* * Exponentiation of zero by negative number in an expression. Control * only reaches this point by "goto exponOfZero". */ exponOfZero: - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponentiation of zero by negative power", -1)); + Tcl_SetResult(interp, "exponentiation of zero by negative power", + TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; /* * Almost all error paths feed through here rather than assigning to * result themselves (for a small but consistent saving). */ @@ -6899,26 +6456,24 @@ } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); - DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); - CACHE_STACK_INFO(); + checkInterp = 1; } iPtr->flags &= ~ERR_ALREADY_LOGGED; /* * Clear all expansions that may have started after the last * INST_BEGIN_CATCH. */ while (auxObjList) { - if ((catchTop != initCatchTop) - && (*catchTop > (ptrdiff_t) - auxObjList->internalRep.ptrAndLongRep.value)) { + if ((catchDepth >=0) && (PTR2INT(catchStack[catchDepth]) > + PTR2INT(auxObjList->internalRep.twoPtrValue.ptr1))) { break; } POP_TAUX_OBJ(); } @@ -6954,11 +6509,11 @@ StringForResultCode(result)); } #endif goto abnormalReturn; } - if (catchTop == initCatchTop) { + if (catchDepth == -1) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", StringForResultCode(result)); } @@ -6989,20 +6544,20 @@ * its catchOffset after unwinding the operand stack to the depth it * had when starting to execute the range's catch command. */ processCatch: - while (CURR_DEPTH > *catchTop) { + while (CURR_DEPTH > PTR2INT(catchStack[catchDepth])) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " + fprintf(stdout, " ... found catch at %d, catchDepth=%d, " "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long) *catchTop, (unsigned) rangePtr->catchOffset); + rangePtr->codeOffset, (int) catchDepth, + PTR2INT(catchStack[catchDepth]), (unsigned) rangePtr->catchOffset); } #endif pc = (codePtr->codeStart + rangePtr->catchOffset); NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ @@ -7047,11 +6602,11 @@ iPtr->cmdFramePtr = bcFramePtr->nextPtr; if (--codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - TclStackFree(interp, TD); /* free my stack */ + ckfree(TD); /* free my stack */ return result; /* * INST_START_CMD failure case removed where it doesn't bother that much @@ -7091,14 +6646,13 @@ } #undef codePtr #undef iPtr #undef bcFramePtr -#undef initCatchTop #undef initTosPtr #undef auxObjList -#undef catchTop +#undef catchDepth #undef TCONST /* *---------------------------------------------------------------------- * Index: generic/tclFCmd.c ================================================================== --- generic/tclFCmd.c +++ generic/tclFCmd.c @@ -1005,11 +1005,11 @@ if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStringsAllocated = (const char **) - TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *)); + ckalloc((1+numObjStrings) * sizeof(char *)); for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); attributeStringsAllocated[index] = TclGetString(objPtr); } attributeStringsAllocated[index] = NULL; @@ -1136,11 +1136,11 @@ * attribute names issued by the filesystem. */ end: if (attributeStringsAllocated != NULL) { - TclStackFree(interp, (void *) attributeStringsAllocated); + ckfree((void *) attributeStringsAllocated); } if (objStrings != NULL) { Tcl_DecrRefCount(objStrings); } return result; Index: generic/tclFileName.c ================================================================== --- generic/tclFileName.c +++ generic/tclFileName.c @@ -1447,11 +1447,11 @@ Tcl_ListObjLength(interp, typePtr, &length); if (length <= 0) { goto skipTypes; } - globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); + globTypes = ckalloc(sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; globTypes->macCreator = NULL; @@ -1667,11 +1667,11 @@ Tcl_DecrRefCount(globTypes->macType); } if (globTypes->macCreator != NULL) { Tcl_DecrRefCount(globTypes->macCreator); } - TclStackFree(interp, globTypes); + ckfree(globTypes); } return result; } /* Index: generic/tclIOCmd.c ================================================================== --- generic/tclIOCmd.c +++ generic/tclIOCmd.c @@ -929,11 +929,11 @@ * Create the string argument array "argv". Make sure argv is large enough * to hold the argc arguments plus 1 extra for the zero end-of-argv word. */ argc = objc - skip; - argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); + argv = ckalloc((unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the * argument vector. */ @@ -947,11 +947,11 @@ /* * Free the argv array. */ - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); if (chan == NULL) { return TCL_ERROR; } Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -967,17 +967,16 @@ } flags = 0; len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned)len + 1); + char *quotedElementStr = ckalloc((unsigned)len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); - TclStackFree(interp, quotedElementStr); + ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } AFTER_FIRST_WORD; @@ -1023,17 +1022,16 @@ elementStr = TclGetStringFromObj(objv[i], &elemLen); flags = 0; len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned) len + 1); + char *quotedElementStr = ckalloc((unsigned) len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); - TclStackFree(interp, quotedElementStr); + ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } } Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -32,13 +32,13 @@ # int TclAccessDeleteProc(TclAccessProc_ *proc) #} #declare 2 { # int TclAccessInsertProc(TclAccessProc_ *proc) #} -declare 3 { - void TclAllocateFreeObjects(void) -} +#declare 3 { +# void TclAllocateFreeObjects(void) +#} # Replaced by TclpChdir in 8.1: # declare 4 { # int TclChdir(Tcl_Interp *interp, char *dirName) # } declare 5 { @@ -287,13 +287,13 @@ #} # Replaced by Tcl_FSAccess in 8.4: #declare 68 { # int TclpAccess(const char *path, int mode) #} -declare 69 { - char *TclpAlloc(unsigned int size) -} +#declare 69 { +# char *TclpAlloc(unsigned int size) +#} #declare 70 { # int TclpCopyFile(const char *source, const char *dest) #} #declare 71 { # int TclpCopyDirectory(const char *source, const char *dest, @@ -303,13 +303,13 @@ # int TclpCreateDirectory(const char *path) #} #declare 73 { # int TclpDeleteFile(const char *path) #} -declare 74 { - void TclpFree(char *ptr) -} +#declare 74 { +# void TclpFree(char *ptr) +#} declare 75 { unsigned long TclpGetClicks(void) } declare 76 { unsigned long TclpGetSeconds(void) @@ -330,13 +330,13 @@ # Replaced by Tcl_FSOpenFileChannel in 8.4: #declare 80 { # Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, # char *modeString, int permissions) #} -declare 81 { - char *TclpRealloc(char *ptr, unsigned int size) -} +#declare 81 { +# char *TclpRealloc(char *ptr, unsigned int size) +#} #declare 82 { # int TclpRemoveDirectory(const char *path, int recursive, # Tcl_DString *errorPtr) #} #declare 83 { @@ -868,16 +868,16 @@ Tcl_Obj *TclGetObjNameOfExecutable(void) } declare 214 { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } -declare 215 { - void *TclStackAlloc(Tcl_Interp *interp, int numBytes) -} -declare 216 { - void TclStackFree(Tcl_Interp *interp, void *freePtr) -} +#declare 215 { +# void *TclStackAlloc(Tcl_Interp *interp, unsigned int numBytes) +#} +#declare 216 { +# void TclStackFree(Tcl_Interp *interp, void *freePtr) +#} declare 217 { int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame) } declare 218 { @@ -892,13 +892,13 @@ # declare 225 { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags) } -declare 226 { - int TclObjBeingDeleted(Tcl_Obj *objPtr) -} +#declare 226 { +# int TclObjBeingDeleted(Tcl_Obj *objPtr) +#} declare 227 { void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]) } # Used to be needed for TclOO-extension; unneeded now that TclOO is in the Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -8,11 +8,11 @@ * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. - * Copyright (c) 2008 by Miguel Sofer. All rights reserved. + * Copyright (c) 2008-2011 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. */ @@ -1391,17 +1391,10 @@ */ #define TCL_TSD_INIT(keyPtr) \ (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) -/* - *---------------------------------------------------------------- - * Data structures related to bytecode compilation and execution. These are - * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. - *---------------------------------------------------------------- - */ - /* * Forward declaration to prevent errors when the forward references to * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc * declared below. */ @@ -1439,23 +1432,10 @@ */ typedef int (CompileHookProc)(Tcl_Interp *interp, struct CompileEnv *compEnvPtr, ClientData clientData); -/* - * The data structure for a (linked list of) execution stacks. - */ - -typedef struct ExecStack { - struct ExecStack *prevPtr; - struct ExecStack *nextPtr; - Tcl_Obj **markerPtr; - Tcl_Obj **endPtr; - Tcl_Obj **tosPtr; - Tcl_Obj *stackWords[1]; -} ExecStack; - /* * The data structure defining the execution environment for ByteCode's. * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation * stack that holds command operands and results. The stack grows towards * increasing addresses. The member stackPtr points to the stackItems of the @@ -1489,12 +1469,10 @@ * coroutine; -2 means "0 or 1" (default), -1 * means "any" */ } CoroutineData; typedef struct ExecEnv { - ExecStack *execStackPtr; /* Points to the first item in the evaluation - * stack on the heap. */ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ struct Tcl_Interp *interp; struct NRE_callback *callbackPtr; /* Top callback in NRE's stack. */ struct CoroutineData *corPtr; @@ -1769,28 +1747,10 @@ enum PkgPreferOptions { PKG_PREFER_LATEST, PKG_PREFER_STABLE }; -/* - *---------------------------------------------------------------- - * This structure shadows the first few fields of the memory cache for the - * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the - * definition there. - * Some macros require knowledge of some fields in the struct in order to - * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer - * to the relevant fields is kept in the objCache field in struct Interp. - *---------------------------------------------------------------- - */ - -typedef struct AllocCache { - struct Cache *nextPtr; /* Linked list of cache entries. */ - Tcl_ThreadId owner; /* Which thread's cache is this? */ - Tcl_Obj *firstObjPtr; /* List of free objects for thread. */ - int numObjects; /* Number of objects for thread. */ -} AllocCache; - /* *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of commands * plus other state information related to interpreting commands, such as * variable storage. Primary responsibility for this data structure is in @@ -2120,14 +2080,10 @@ * inherit the value. * * They are used by the macros defined below. */ - AllocCache *allocCache; - void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData - * structs for this interp's thread; see - * tclObj.c and tclThreadAlloc.c */ int *asyncReadyPtr; /* Pointer to the asyncReady indicator for * this interp's thread; see tclAsync.c */ /* * The pointer to the object system root ekeko. c.f. TIP #257. */ @@ -2351,21 +2307,10 @@ * isspace. */ #define UCHAR(c) ((unsigned char) (c)) -/* - * This macro is used to properly align the memory allocated by Tcl, giving - * the same alignment as the native malloc. - */ - -#if defined(__APPLE__) -#define TCL_ALLOCALIGN 16 -#else -#define TCL_ALLOCALIGN (2*sizeof(void *)) -#endif - /* * This macro is used to determine the offset needed to safely allocate any * data structure in memory. Given a starting offset or size, it "rounds up" * or "aligns" the offset to the next 8-byte boundary so that any data * structure can be placed at the resulting offset without fear of an @@ -2748,17 +2693,10 @@ MODULE_SCOPE const Tcl_HashKeyType tclArrayHashKeyType; MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType; MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType; MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType; -/* - * The head of the list of free Tcl objects, and the total number of Tcl - * objects ever allocated and freed. - */ - -MODULE_SCOPE Tcl_Obj * tclFreeObjList; - #ifdef TCL_COMPILE_STATS MODULE_SCOPE long tclObjsAlloced; MODULE_SCOPE long tclObjsFreed; #define TCL_MAX_SHARED_OBJ_STATS 5 MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; @@ -2942,11 +2880,10 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); -MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); MODULE_SCOPE void TclFinalizeEvaluation(void); @@ -2959,11 +2896,10 @@ MODULE_SCOPE void TclFinalizeMemorySubsystem(void); MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); -MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadData(void); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, @@ -3002,11 +2938,10 @@ int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); @@ -3139,12 +3074,10 @@ Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); -MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - int numBytes); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); @@ -3997,14 +3930,14 @@ # define TclIncrObjsAllocated() # define TclIncrObjsFreed() #endif /* TCL_COMPILE_STATS */ # define TclAllocObjStorage(objPtr) \ - TclAllocObjStorageEx(NULL, (objPtr)) + (objPtr) = TclSmallAlloc() # define TclFreeObjStorage(objPtr) \ - TclFreeObjStorageEx(NULL, (objPtr)) + TclSmallFree(objPtr) #ifndef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ @@ -4035,116 +3968,10 @@ } else { \ TclFreeObj(objPtr); \ } \ } -#if defined(PURIFY) - -/* - * The PURIFY mode is like the regular mode, but instead of doing block - * Tcl_Obj allocation and keeping a freed list for efficiency, it always - * allocates and frees a single Tcl_Obj so that tools like Purify can better - * track memory leaks. - */ - -# define TclAllocObjStorageEx(interp, objPtr) \ - (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) - -# define TclFreeObjStorageEx(interp, objPtr) \ - ckfree((char *) (objPtr)) - -#undef USE_THREAD_ALLOC -#undef USE_TCLALLOC -#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - -/* - * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from - * per-thread caches. - */ - -MODULE_SCOPE Tcl_Obj * TclThreadAllocObj(void); -MODULE_SCOPE void TclThreadFreeObj(Tcl_Obj *); -MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); -MODULE_SCOPE void TclFreeAllocCache(void *); -MODULE_SCOPE void * TclpGetAllocCache(void); -MODULE_SCOPE void TclpSetAllocCache(void *); -MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); -MODULE_SCOPE void TclpFreeAllocCache(void *); - -/* - * These macros need to be kept in sync with the code of TclThreadAllocObj() - * and TclThreadFreeObj(). - * - * Note that the optimiser should resolve the case (interp==NULL) at compile - * time. - */ - -# define ALLOC_NOBJHIGH 1200 - -# define TclAllocObjStorageEx(interp, objPtr) \ - do { \ - AllocCache *cachePtr; \ - if (((interp) == NULL) || \ - ((cachePtr = ((Interp *)(interp))->allocCache), \ - (cachePtr->numObjects == 0))) { \ - (objPtr) = TclThreadAllocObj(); \ - } else { \ - (objPtr) = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \ - --cachePtr->numObjects; \ - } \ - } while (0) - -# define TclFreeObjStorageEx(interp, objPtr) \ - do { \ - AllocCache *cachePtr; \ - if (((interp) == NULL) || \ - ((cachePtr = ((Interp *)(interp))->allocCache), \ - (cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \ - TclThreadFreeObj(objPtr); \ - } else { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = objPtr; \ - ++cachePtr->numObjects; \ - } \ - } while (0) - -#else /* not PURIFY or USE_THREAD_ALLOC */ - -#if defined(USE_TCLALLOC) && USE_TCLALLOC - MODULE_SCOPE void TclFinalizeAllocSubsystem(); - MODULE_SCOPE void TclInitAlloc(); -#else -# define USE_TCLALLOC 0 -#endif - -#ifdef TCL_THREADS -/* declared in tclObj.c */ -MODULE_SCOPE Tcl_Mutex tclObjMutex; -#endif - -# define TclAllocObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ - if (tclFreeObjList == NULL) { \ - TclAllocateFreeObjects(); \ - } \ - (objPtr) = tclFreeObjList; \ - tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.twoPtrValue.ptr1; \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) - -# define TclFreeObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) -#endif - #else /* TCL_MEM_DEBUG */ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, int line); # define TclDbNewObj(objPtr, file, line) \ @@ -4163,12 +3990,62 @@ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) # define TclNewListObjDirect(objc, objv) \ TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__) -#undef USE_THREAD_ALLOC #endif /* TCL_MEM_DEBUG */ + +/* + * Macros that drive the allocator behaviour + */ + +#if defined(TCL_THREADS) +/* + * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from + * per-thread caches. + */ +MODULE_SCOPE void TclpFreeAllocCache(void *); +MODULE_SCOPE void * TclpGetAllocCache(void); +MODULE_SCOPE void TclpSetAllocCache(void *); +MODULE_SCOPE void TclFreeAllocCache(void *); +MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); +MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); +#endif + +MODULE_SCOPE char * TclpAlloc(unsigned int size); +MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size); +MODULE_SCOPE void TclpFree(char * ptr); + +MODULE_SCOPE void * TclSmallAlloc(); +MODULE_SCOPE void TclSmallFree(void *ptr); +MODULE_SCOPE void TclInitAlloc(void); +MODULE_SCOPE void TclFinalizeAlloc(void); + +#define TclCkSmallAlloc(nbytes, memPtr) \ + do { \ + TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ + memPtr = TclSmallAlloc(); \ + } while (0) + +/* + * Support for Clang Static Analyzer + */ + +#if defined(PURIFY) && defined(__clang__) +#if __has_feature(attribute_analyzer_noreturn) && \ + !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED) +void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); +#endif +#if !defined(CLANG_ASSERT) +#include +#define CLANG_ASSERT(x) assert(x) +#endif +#elif !defined(CLANG_ASSERT) + #define CLANG_ASSERT(x) +#endif /* PURIFY && __clang__ */ + + /* *---------------------------------------------------------------- * Macro used by the Tcl core to set a Tcl_Obj's string representation to a * copy of the "len" bytes starting at "bytePtr". This code works even if the @@ -4700,78 +4577,16 @@ */ #define TCL_CT_ASSERT(e) \ {enum { ct_assert_value = 1/(!!(e)) };} -/* - *---------------------------------------------------------------- - * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool. - * Only checked at compile time. - * - * ONLY USE FOR CONSTANT nBytes. - * - * DO NOT LET THEM CROSS THREAD BOUNDARIES - *---------------------------------------------------------------- - */ - -#define TclSmallAlloc(nbytes, memPtr) \ - TclSmallAllocEx(NULL, (nbytes), (memPtr)) - -#define TclSmallFree(memPtr) \ - TclSmallFreeEx(NULL, (memPtr)) - -#ifndef TCL_MEM_DEBUG -#define TclSmallAllocEx(interp, nbytes, memPtr) \ - do { \ - Tcl_Obj *objPtr; \ - TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - TclIncrObjsAllocated(); \ - TclAllocObjStorageEx((interp), (objPtr)); \ - memPtr = (ClientData) (objPtr); \ - } while (0) - -#define TclSmallFreeEx(interp, memPtr) \ - do { \ - TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \ - TclIncrObjsFreed(); \ - } while (0) - -#else /* TCL_MEM_DEBUG */ -#define TclSmallAllocEx(interp, nbytes, memPtr) \ - do { \ - Tcl_Obj *objPtr; \ - TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - TclNewObj(objPtr); \ - memPtr = (ClientData) objPtr; \ - } while (0) - -#define TclSmallFreeEx(interp, memPtr) \ - do { \ - Tcl_Obj *objPtr = (Tcl_Obj *) memPtr; \ - objPtr->bytes = NULL; \ - objPtr->typePtr = NULL; \ - objPtr->refCount = 1; \ - TclDecrRefCount(objPtr); \ - } while (0) -#endif /* TCL_MEM_DEBUG */ - /* * Support for Clang Static Analyzer */ -#if defined(PURIFY) && defined(__clang__) -#if __has_feature(attribute_analyzer_noreturn) && \ - !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED) -void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); -#endif -#if !defined(CLANG_ASSERT) -#include -#define CLANG_ASSERT(x) assert(x) -#endif -#elif !defined(CLANG_ASSERT) #define CLANG_ASSERT(x) -#endif /* PURIFY && __clang__ */ + /* *---------------------------------------------------------------- * Parameters, structs and macros for the non-recursive engine (NRE) *---------------------------------------------------------------- @@ -4811,12 +4626,12 @@ TOP_CB(interp) = callbackPtr; \ } while (0) #if NRE_USE_SMALL_ALLOC #define TCLNR_ALLOC(interp, ptr) \ - TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr)) -#define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr)) + TclCkSmallAlloc(sizeof(NRE_callback), (ptr)) +#define TCLNR_FREE(interp, ptr) TclSmallFree(ptr) #else #define TCLNR_ALLOC(interp, ptr) \ (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) #define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) #endif Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -57,12 +57,11 @@ */ /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ -/* 3 */ -EXTERN void TclAllocateFreeObjects(void); +/* Slot 3 is reserved */ /* Slot 4 is reserved */ /* 5 */ EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ @@ -199,29 +198,26 @@ Tcl_Obj *const objv[], int flags); /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ -/* 69 */ -EXTERN char * TclpAlloc(unsigned int size); +/* Slot 69 is reserved */ /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ -/* 74 */ -EXTERN void TclpFree(char *ptr); +/* Slot 74 is reserved */ /* 75 */ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ EXTERN void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ -/* 81 */ -EXTERN char * TclpRealloc(char *ptr, unsigned int size); +/* Slot 81 is reserved */ /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ @@ -512,14 +508,12 @@ /* 213 */ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); /* 214 */ EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); -/* 215 */ -EXTERN void * TclStackAlloc(Tcl_Interp *interp, int numBytes); -/* 216 */ -EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); +/* Slot 215 is reserved */ +/* Slot 216 is reserved */ /* 217 */ EXTERN int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); @@ -534,12 +528,11 @@ EXTERN TclPlatformType * TclGetPlatform(void); /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); -/* 226 */ -EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); +/* Slot 226 is reserved */ /* 227 */ EXTERN void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* Slot 228 is reserved */ /* 229 */ @@ -616,11 +609,11 @@ void *hooks; void (*reserved0)(void); void (*reserved1)(void); void (*reserved2)(void); - void (*tclAllocateFreeObjects) (void); /* 3 */ + void (*reserved3)(void); void (*reserved4)(void); int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ @@ -682,23 +675,23 @@ int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */ void (*reserved65)(void); void (*reserved66)(void); void (*reserved67)(void); void (*reserved68)(void); - char * (*tclpAlloc) (unsigned int size); /* 69 */ + void (*reserved69)(void); void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); - void (*tclpFree) (char *ptr); /* 74 */ + void (*reserved74)(void); unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); - char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ + void (*reserved81)(void); void (*reserved82)(void); void (*reserved83)(void); void (*reserved84)(void); void (*reserved85)(void); void (*reserved86)(void); @@ -828,22 +821,22 @@ void (*reserved210)(void); void (*reserved211)(void); void (*tclpFindExecutable) (const char *argv0); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */ void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */ - void * (*tclStackAlloc) (Tcl_Interp *interp, int numBytes); /* 215 */ - void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */ + void (*reserved215)(void); + void (*reserved216)(void); int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */ void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */ void (*reserved219)(void); void (*reserved220)(void); void (*reserved221)(void); void (*reserved222)(void); void (*reserved223)(void); TclPlatformType * (*tclGetPlatform) (void); /* 224 */ Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ - int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ + void (*reserved226)(void); void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ @@ -883,12 +876,11 @@ */ /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ -#define TclAllocateFreeObjects \ - (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */ +/* Slot 3 is reserved */ /* Slot 4 is reserved */ #define TclCleanupChildren \ (tclIntStubsPtr->tclCleanupChildren) /* 5 */ #define TclCleanupCommand \ (tclIntStubsPtr->tclCleanupCommand) /* 6 */ @@ -988,29 +980,26 @@ (tclIntStubsPtr->tclObjInvoke) /* 64 */ /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ -#define TclpAlloc \ - (tclIntStubsPtr->tclpAlloc) /* 69 */ +/* Slot 69 is reserved */ /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ -#define TclpFree \ - (tclIntStubsPtr->tclpFree) /* 74 */ +/* Slot 74 is reserved */ #define TclpGetClicks \ (tclIntStubsPtr->tclpGetClicks) /* 75 */ #define TclpGetSeconds \ (tclIntStubsPtr->tclpGetSeconds) /* 76 */ #define TclpGetTime \ (tclIntStubsPtr->tclpGetTime) /* 77 */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ -#define TclpRealloc \ - (tclIntStubsPtr->tclpRealloc) /* 81 */ +/* Slot 81 is reserved */ /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ @@ -1229,14 +1218,12 @@ (tclIntStubsPtr->tclpFindExecutable) /* 212 */ #define TclGetObjNameOfExecutable \ (tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */ #define TclSetObjNameOfExecutable \ (tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */ -#define TclStackAlloc \ - (tclIntStubsPtr->tclStackAlloc) /* 215 */ -#define TclStackFree \ - (tclIntStubsPtr->tclStackFree) /* 216 */ +/* Slot 215 is reserved */ +/* Slot 216 is reserved */ #define TclPushStackFrame \ (tclIntStubsPtr->tclPushStackFrame) /* 217 */ #define TclPopStackFrame \ (tclIntStubsPtr->tclPopStackFrame) /* 218 */ /* Slot 219 is reserved */ @@ -1246,12 +1233,11 @@ /* Slot 223 is reserved */ #define TclGetPlatform \ (tclIntStubsPtr->tclGetPlatform) /* 224 */ #define TclTraceDictPath \ (tclIntStubsPtr->tclTraceDictPath) /* 225 */ -#define TclObjBeingDeleted \ - (tclIntStubsPtr->tclObjBeingDeleted) /* 226 */ +/* Slot 226 is reserved */ #define TclSetNsPath \ (tclIntStubsPtr->tclSetNsPath) /* 227 */ /* Slot 228 is reserved */ #define TclPtrMakeUpvar \ (tclIntStubsPtr->tclPtrMakeUpvar) /* 229 */ Index: generic/tclInterp.c ================================================================== --- generic/tclInterp.c +++ generic/tclInterp.c @@ -1131,11 +1131,11 @@ Tcl_Obj *slaveObjPtr, *targetObjPtr; Tcl_Obj **objv; int i; int result; - objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); + objv = ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); } @@ -1149,11 +1149,11 @@ targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(slaveInterp, objv); + ckfree(objv); Tcl_DecrRefCount(targetObjPtr); Tcl_DecrRefCount(slaveObjPtr); return result; } @@ -1829,11 +1829,11 @@ prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + cmdv = ckalloc(cmdc * sizeof(Tcl_Obj *)); } prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); @@ -1896,11 +1896,11 @@ for (i=0; ielemCount; numRequired = numElems + 1 ; + needGrow = (numRequired > listRepPtr->maxElemCount); isShared = (listRepPtr->refCount > 1); if (numRequired > LIST_MAX) { if (interp != NULL) { Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -463,11 +463,11 @@ * for a "namespace eval" or "namespace * inscope" command and var references are * treated as references to namespace * variables. */ { - *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame)); + *framePtrPtr = ckalloc(sizeof(CallFrame)); return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); } void @@ -475,11 +475,11 @@ Tcl_Interp *interp) /* Interpreter with call frame to pop. */ { CallFrame *freePtr = ((Interp *) interp)->framePtr; Tcl_PopCallFrame(interp); - TclStackFree(interp, freePtr); + ckfree(freePtr); } /* *---------------------------------------------------------------------- * @@ -2639,12 +2639,11 @@ Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); int found, i; int trailFront = -1; int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ - Namespace **trailPtr = TclStackAlloc(interp, - trailSize * sizeof(Namespace *)); + Namespace **trailPtr = ckalloc(trailSize * sizeof(Namespace *)); /* * Start at the namespace containing the new command, and work up through * the list of parents. Stop just before the global namespace, since the * global namespace can't "shadow" its own entries. @@ -2729,17 +2728,16 @@ trailFront++; if (trailFront == trailSize) { int newSize = 2 * trailSize; - trailPtr = TclStackRealloc(interp, trailPtr, - newSize * sizeof(Namespace *)); + trailPtr = ckrealloc(trailPtr, newSize * sizeof(Namespace *)); trailSize = newSize; } trailPtr[trailFront] = nsPtr; } - TclStackFree(interp, trailPtr); + ckfree(trailPtr); } /* *---------------------------------------------------------------------- * @@ -3976,12 +3974,11 @@ if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { - namespaceList = TclStackAlloc(interp, - sizeof(Tcl_Namespace *) * nsObjc); + namespaceList = ckalloc(sizeof(Tcl_Namespace *) * nsObjc); for (i=0 ; ioPtr; TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { - TclStackFree(oPtr->fPtr->interp, contextPtr); + ckfree(contextPtr); DelRef(oPtr); } } /* @@ -1102,11 +1102,11 @@ oPtr->selfCls->destructorChainPtr = callPtr; callPtr->refCount++; } returnContext: - contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); + contextPtr = ckalloc(sizeof(CallContext)); contextPtr->oPtr = oPtr; AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; contextPtr->index = 0; @@ -1443,11 +1443,11 @@ * the method in question (which differs for "unknown" and "filter" types) * and the third word is the full name of the class that declares the * method (or "object" if it is declared on the instance). */ - objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); + objv = ckalloc(callPtr->numChain * sizeof(Tcl_Obj *)); for (i=0 ; inumChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; descObjs[0] = miPtr->isFilter ? filterLiteral @@ -1480,11 +1480,11 @@ /* * Finish building the description and return it. */ resultObj = Tcl_NewListObj(callPtr->numChain, objv); - TclStackFree(interp, objv); + ckfree(objv); return resultObj; } /* * Local Variables: Index: generic/tclOODefineCmds.c ================================================================== --- generic/tclOODefineCmds.c +++ generic/tclOODefineCmds.c @@ -543,21 +543,21 @@ if (matchedStr != NULL) { /* * Got one match, and only one match! */ - Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1)); + Tcl_Obj **newObjv = ckalloc(sizeof(Tcl_Obj*)*(objc-1)); int result; newObjv[0] = Tcl_NewStringObj(matchedStr, -1); Tcl_IncrRefCount(newObjv[0]); if (objc > 2) { memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); } result = Tcl_EvalObjv(interp, objc-1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); - TclStackFree(interp, newObjv); + ckfree(newObjv); return result; } noMatch: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1651,11 +1651,11 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); + mixins = ckalloc(sizeof(Class *) * (objc-1)); for (i=1 ; iclassPtr, objc-1, mixins); } - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_OK; freeAndError: - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- @@ -2088,11 +2088,11 @@ } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } - mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + mixins = ckalloc(sizeof(Class *) * mixinc); for (i=0 ; iclassPtr, mixinc, mixins); - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_OK; freeAndError: - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- @@ -2529,23 +2529,23 @@ if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } - mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + mixins = ckalloc(sizeof(Class *) * mixinc); for (i=0 ; irefCount++; /* @@ -717,15 +717,15 @@ */ pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; Tcl_PopCallFrame(interp); - TclStackFree(interp, fdPtr->framePtr); + ckfree(fdPtr->framePtr); if (--pmPtr->refCount < 1) { DeleteProcedureMethodRecord(pmPtr); } - TclStackFree(interp, fdPtr); + ckfree(fdPtr); return result; } } /* @@ -772,11 +772,11 @@ */ if (--pmPtr->refCount < 1) { DeleteProcedureMethodRecord(pmPtr); } - TclStackFree(interp, fdPtr); + ckfree(fdPtr); return result; } static int PushMethodCallFrame( @@ -1438,11 +1438,11 @@ Tcl_Interp *interp, int result) { Tcl_Obj **argObjs = data[0]; - TclStackFree(interp, argObjs); + ckfree(argObjs); return result; } /* * ---------------------------------------------------------------------- @@ -1567,11 +1567,11 @@ Interp *iPtr = (Interp *) interp; int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); Tcl_Obj **argObjs; unsigned len = rewriteLength + objc - toRewrite; - argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); + argObjs = ckalloc(sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); memcpy(argObjs + rewriteLength, objv + toRewrite, sizeof(Tcl_Obj *) * (objc - toRewrite)); /* Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -24,24 +24,12 @@ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) -/* - * Head of the list of free Tcl_Obj structs we maintain. - */ - -Tcl_Obj *tclFreeObjList = NULL; - -/* - * The object allocator is single threaded. This mutex is referenced by the - * TclNewObj macro, however, so must be visible. - */ - -#ifdef TCL_THREADS -MODULE_SCOPE Tcl_Mutex tclObjMutex; -Tcl_Mutex tclObjMutex; +#if (defined(TCL_THREADS) && TCL_MEM_DEBUG) +static Tcl_Mutex tclObjMutex; #endif /* * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is @@ -496,19 +484,10 @@ if (typeTableInitialized) { Tcl_DeleteHashTable(&typeTable); typeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); - - /* - * All we do here is reset the head pointer of the linked list of free - * Tcl_Obj's to NULL; the memory finalization will take care of releasing - * memory for us. - */ - Tcl_MutexLock(&tclObjMutex); - tclFreeObjList = NULL; - Tcl_MutexUnlock(&tclObjMutex); } /* *---------------------------------------------------------------------- * @@ -1239,63 +1218,10 @@ #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * - * TclAllocateFreeObjects -- - * - * Function to allocate a number of free Tcl_Objs. This is done using a - * single ckalloc to reduce the overhead for Tcl_Obj allocation. - * - * Assumes mutex is held. - * - * Results: - * None. - * - * Side effects: - * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the - * first of a number of free Tcl_Obj's linked together by their - * internalRep.twoPtrValue.ptr1's. - * - *---------------------------------------------------------------------- - */ - -#define OBJS_TO_ALLOC_EACH_TIME 100 - -void -TclAllocateFreeObjects(void) -{ - size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); - char *basePtr; - register Tcl_Obj *prevPtr, *objPtr; - register int i; - - /* - * This has been noted by Purify to be a potential leak. The problem is - * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated - * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually - * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, - * but leaves it to Tcl's memory subsystem finalization to release it. - * Purify apparently can't figure that out, and fires a false alarm. - */ - - basePtr = ckalloc(bytesToAlloc); - - prevPtr = NULL; - objPtr = (Tcl_Obj *) basePtr; - for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; - prevPtr = objPtr; - objPtr++; - } - tclFreeObjList = prevPtr; -} -#undef OBJS_TO_ALLOC_EACH_TIME - -/* - *---------------------------------------------------------------------- - * * TclFreeObj -- * * This function frees the memory associated with the argument object. * It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref * count is zero. It is only "public" since it must be callable by that @@ -1337,11 +1263,10 @@ * pointer chain, and signal an obj deletion (as opposed to shimmering) * with 'length == -1'. */ TclInvalidateStringRep(objPtr); - objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { TCL_DTRACE_OBJ_FREE(objPtr); @@ -1405,11 +1330,10 @@ * pointer chain, and signal an obj deletion (as opposed to shimmering) * with 'length == -1'. */ TclInvalidateStringRep(objPtr); - objPtr->length = -1; if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* * objPtr can be freed safely, as it will not attempt to free any * other objects: it will not cause recursive calls to this function. @@ -1484,35 +1408,10 @@ } } } } #endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclObjBeingDeleted -- - * - * This function returns 1 when the Tcl_Obj is being deleted. It is - * provided for the rare cases where the reason for the loss of an - * internal rep might be relevant. [FR 1512138] - * - * Results: - * 1 if being deleted, 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclObjBeingDeleted( - Tcl_Obj *objPtr) -{ - return (objPtr->length == -1); -} /* *---------------------------------------------------------------------- * * Tcl_DuplicateObj -- Index: generic/tclParse.c ================================================================== --- generic/tclParse.c +++ generic/tclParse.c @@ -1147,18 +1147,18 @@ * parse information. */ src++; numBytes--; - nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse)); + nestedPtr = ckalloc(sizeof(Tcl_Parse)); while (1) { if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1, nestedPtr) != TCL_OK) { parsePtr->errorType = nestedPtr->errorType; parsePtr->term = nestedPtr->term; parsePtr->incomplete = nestedPtr->incomplete; - TclStackFree(parsePtr->interp, nestedPtr); + ckfree(nestedPtr); return TCL_ERROR; } src = nestedPtr->commandStart + nestedPtr->commandSize; numBytes = parsePtr->end - src; Tcl_FreeParse(nestedPtr); @@ -1180,15 +1180,15 @@ "missing close-bracket", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; parsePtr->incomplete = 1; - TclStackFree(parsePtr->interp, nestedPtr); + ckfree(nestedPtr); return TCL_ERROR; } } - TclStackFree(parsePtr->interp, nestedPtr); + ckfree(nestedPtr); tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->size = src - tokenPtr->start; parsePtr->numTokens++; } else if (*src == '\\') { if (noSubstBS) { @@ -1544,14 +1544,14 @@ * character just after last one in the * variable specifier. */ { register Tcl_Obj *objPtr; int code; - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) { - TclStackFree(interp, parsePtr); + ckfree(parsePtr); return NULL; } if (termPtr != NULL) { *termPtr = start + parsePtr->tokenPtr->size; @@ -1559,17 +1559,17 @@ if (parsePtr->numTokens == 1) { /* * There isn't a variable name after all: the $ is just a $. */ - TclStackFree(interp, parsePtr); + ckfree(parsePtr); return "$"; } code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); - TclStackFree(interp, parsePtr); + ckfree(parsePtr); if (code != TCL_OK) { return NULL; } objPtr = Tcl_GetObjResult(interp); @@ -2028,11 +2028,11 @@ */ Tcl_Token *tokenPtr; const char *lastTerm = parsePtr->term; Tcl_Parse *nestedPtr = - TclStackAlloc(interp, sizeof(Tcl_Parse)); + ckalloc(sizeof(Tcl_Parse)); while (TCL_OK == Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) { Tcl_FreeParse(nestedPtr); p = nestedPtr->term + (nestedPtr->term < nestedPtr->end); @@ -2046,11 +2046,11 @@ break; } lastTerm = nestedPtr->term; } - TclStackFree(interp, nestedPtr); + ckfree(nestedPtr); if (lastTerm == parsePtr->term) { /* * Parse error in first command. No commands to subst, add * no more tokens. Index: generic/tclPreserve.c ================================================================== --- generic/tclPreserve.c +++ generic/tclPreserve.c @@ -11,10 +11,15 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" + +/* + * Only use this file if we are NOT using the new code in tclAlloc.c + */ + /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. @@ -43,31 +48,10 @@ * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ #define INITIAL_SIZE 2 /* Initial number of reference slots to make */ -/* - * The following data structure is used to keep track of whether an arbitrary - * block of memory has been deleted. This is used by the TclHandle code to - * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism - * is mainly used when we have lots of references to a few big, expensive - * objects that we don't want to live any longer than necessary. - */ - -typedef struct HandleStruct { - void *ptr; /* Pointer to the memory block being tracked. - * This field will become NULL when the memory - * block is deleted. This field must be the - * first in the structure. */ -#ifdef TCL_MEM_DEBUG - void *ptr2; /* Backup copy of the above pointer used to - * ensure that the contents of the handle are - * not changed by anyone else. */ -#endif - int refCount; /* Number of TclHandlePreserve() calls in - * effect on this handle. */ -} HandleStruct; /* *---------------------------------------------------------------------- * * TclFinalizePreserve -- @@ -295,10 +279,32 @@ } else { freeProc(clientData); } } +/* + * The following data structure is used to keep track of whether an arbitrary + * block of memory has been deleted. This is used by the TclHandle code to + * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism + * is mainly used when we have lots of references to a few big, expensive + * objects that we don't want to live any longer than necessary. + */ + +typedef struct HandleStruct { + void *ptr; /* Pointer to the memory block being tracked. + * This field will become NULL when the memory + * block is deleted. This field must be the + * first in the structure. */ +#ifdef TCL_MEM_DEBUG + void *ptr2; /* Backup copy of the above pointer used to + * ensure that the contents of the handle are + * not changed by anyone else. */ +#endif + int refCount; /* Number of TclHandlePreserve() calls in + * effect on this handle. */ +} HandleStruct; + /* *--------------------------------------------------------------------------- * * TclHandleCreate -- * Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -225,11 +225,11 @@ * processing. Find a way to factor the common elements into a single * function. */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr = ckalloc(sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve source information from the bytecode, if possible. If @@ -303,11 +303,11 @@ */ Tcl_DecrRefCount(contextPtr->data.eval.path); contextPtr->data.eval.path = NULL; } - TclStackFree(interp, contextPtr); + ckfree(contextPtr); } /* * Optimize for no-op procs: if the body is not precompiled (like a TclPro * procbody), and the argument list is just "args" and the body is empty, @@ -1115,12 +1115,11 @@ /* * Build up desired argument list for Tcl_WrongNumArgs */ numArgs = framePtr->procPtr->numArgs; - desiredObjs = TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * (numArgs+1)); + desiredObjs = ckalloc((int) sizeof(Tcl_Obj *) * (numArgs+1)); if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1; @@ -1156,11 +1155,11 @@ Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); for (i=0 ; i<=numArgs ; i++) { Tcl_DecrRefCount(desiredObjs[i]); } - TclStackFree(interp, desiredObjs); + ckfree(desiredObjs); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1470,11 +1469,11 @@ * Create the "compiledLocals" array. Make sure it is large enough to hold * all the procedure's compiled local variables, including its formal * parameters. */ - varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var))); + varPtr = ckalloc((int)(localCt * sizeof(Var))); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; /* * Match and assign the call's actual parameters to the procedure's formal @@ -1761,13 +1760,13 @@ result = InitArgsAndLocals(interp, procNameObj, skip); if (result != TCL_OK) { freePtr = iPtr->framePtr; Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); + ckfree(freePtr->compiledLocals); /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ + ckfree(freePtr); /* Free CallFrame. */ return TCL_ERROR; } #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { @@ -1933,13 +1932,13 @@ * allocated later on the stack. */ freePtr = iPtr->framePtr; Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); + ckfree(freePtr->compiledLocals); /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ + ckfree(freePtr); /* Free CallFrame. */ return result; } /* @@ -2551,11 +2550,11 @@ * previous paragraph to track into the list. Find a way to factor the * common elements into a single function. */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr = ckalloc(sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve the source context from the bytecode. This call @@ -2612,11 +2611,11 @@ * it's holding to the source file path */ Tcl_DecrRefCount(contextPtr->data.eval.path); } - TclStackFree(interp, contextPtr); + ckfree(contextPtr); } Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, &isNew), cfPtr); /* @@ -2750,11 +2749,11 @@ result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return TCL_ERROR; } - extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData)); + extraPtr = ckalloc(sizeof(ApplyExtraData)); memset(&extraPtr->cmd, 0, sizeof(Command)); procPtr->cmdPtr = &extraPtr->cmd; extraPtr->cmd.nsPtr = (Namespace *) nsPtr; /* @@ -2801,11 +2800,11 @@ if (extraPtr->isRootEnsemble) { ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; } - TclStackFree(interp, extraPtr); + ckfree(extraPtr); return result; } /* *---------------------------------------------------------------------- Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -257,11 +257,11 @@ { int gotXpg, gotSequential, value, i, flags; char *end; Tcl_UniChar ch; int objIndex, xpgSize, nspace = numVars; - int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); + int *nassign = ckalloc(nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; Tcl_Obj *errorMsg; /* Place to build an error messages. Note that * these are messy operations because we do * not want to use the formatting engine; * we're inside there! */ @@ -478,12 +478,11 @@ if (xpgSize) { nspace = xpgSize; } else { nspace += 16; /* formerly STATIC_LIST_SIZE */ } - nassign = TclStackRealloc(interp, nassign, - nspace * sizeof(int)); + nassign = ckrealloc(nassign, nspace * sizeof(int)); for (i = value; i < nspace; i++) { nassign[i] = 0; } } nassign[objIndex]++; @@ -524,11 +523,11 @@ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); goto error; } } - TclStackFree(interp, nassign); + ckfree(nassign); return TCL_OK; badIndex: if (gotXpg) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -540,11 +539,11 @@ -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); } error: - TclStackFree(interp, nassign); + ckfree(nassign); return TCL_ERROR; } /* *---------------------------------------------------------------------- Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -216,11 +216,11 @@ TCL_STUB_MAGIC, 0, 0, /* 0 */ 0, /* 1 */ 0, /* 2 */ - TclAllocateFreeObjects, /* 3 */ + 0, /* 3 */ 0, /* 4 */ TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ TclCopyAndCollapse, /* 7 */ TclCopyChannelOld, /* 8 */ @@ -282,23 +282,23 @@ TclObjInvoke, /* 64 */ 0, /* 65 */ 0, /* 66 */ 0, /* 67 */ 0, /* 68 */ - TclpAlloc, /* 69 */ + 0, /* 69 */ 0, /* 70 */ 0, /* 71 */ 0, /* 72 */ 0, /* 73 */ - TclpFree, /* 74 */ + 0, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ TclpGetTime, /* 77 */ 0, /* 78 */ 0, /* 79 */ 0, /* 80 */ - TclpRealloc, /* 81 */ + 0, /* 81 */ 0, /* 82 */ 0, /* 83 */ 0, /* 84 */ 0, /* 85 */ 0, /* 86 */ @@ -428,22 +428,22 @@ 0, /* 210 */ 0, /* 211 */ TclpFindExecutable, /* 212 */ TclGetObjNameOfExecutable, /* 213 */ TclSetObjNameOfExecutable, /* 214 */ - TclStackAlloc, /* 215 */ - TclStackFree, /* 216 */ + 0, /* 215 */ + 0, /* 216 */ TclPushStackFrame, /* 217 */ TclPopStackFrame, /* 218 */ 0, /* 219 */ 0, /* 220 */ 0, /* 221 */ 0, /* 222 */ 0, /* 223 */ TclGetPlatform, /* 224 */ TclTraceDictPath, /* 225 */ - TclObjBeingDeleted, /* 226 */ + 0, /* 226 */ TclSetNsPath, /* 227 */ 0, /* 228 */ TclPtrMakeUpvar, /* 229 */ TclObjLookupVar, /* 230 */ TclGetNamespaceFromObj, /* 231 */ Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -6782,11 +6782,11 @@ Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; static ptrdiff_t *refDepth = NULL; ptrdiff_t depth; - Tcl_Obj *levels[6]; + Tcl_Obj *levels[5]; int i = 0; NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; if (refDepth == NULL) { refDepth = &depth; @@ -6796,20 +6796,18 @@ levels[0] = Tcl_NewIntObj(depth); levels[1] = Tcl_NewIntObj(iPtr->numLevels); levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); - levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - - iPtr->execEnvPtr->execStackPtr->stackWords); while (cbPtr) { i++; cbPtr = cbPtr->nextPtr; } - levels[5] = Tcl_NewIntObj(i); + levels[4] = Tcl_NewIntObj(i); - Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels)); + Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels)); return TCL_OK; } /* *---------------------------------------------------------------------- DELETED generic/tclThreadAlloc.c Index: generic/tclThreadAlloc.c ================================================================== --- generic/tclThreadAlloc.c +++ /dev/null @@ -1,1080 +0,0 @@ -/* - * tclThreadAlloc.c -- - * - * This is a very fast storage allocator for used with threads (designed - * avoid lock contention). The basic strategy is to allocate memory in - * fixed size blocks from block caches. - * - * The Initial Developer of the Original Code is America Online, Inc. - * Portions created by AOL are Copyright (C) 1999 America Online, Inc. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - -/* - * If range checking is enabled, an additional byte will be allocated to store - * the magic number at the end of the requested memory. - */ - -#ifndef RCHECK -#ifdef NDEBUG -#define RCHECK 0 -#else -#define RCHECK 1 -#endif -#endif - -/* - * The following define the number of Tcl_Obj's to allocate/move at a time and - * the high water mark to prune a per-thread cache. On a 32 bit system, - * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k. - */ - -#define NOBJALLOC 800 - -/* Actual definition moved to tclInt.h */ -#define NOBJHIGH ALLOC_NOBJHIGH - -/* - * The following union stores accounting information for each block including - * two small magic numbers and a bucket number when in use or a next pointer - * when free. The original requested size (not including the Block overhead) - * is also maintained. - */ - -typedef union Block { - struct { - union { - union Block *next; /* Next in free list. */ - struct { - unsigned char magic1; /* First magic number. */ - unsigned char bucket; /* Bucket block allocated from. */ - unsigned char unused; /* Padding. */ - unsigned char magic2; /* Second magic number. */ - } s; - } u; - size_t reqSize; /* Requested allocation size. */ - } b; - unsigned char padding[TCL_ALLOCALIGN]; -} Block; -#define nextBlock b.u.next -#define sourceBucket b.u.s.bucket -#define magicNum1 b.u.s.magic1 -#define magicNum2 b.u.s.magic2 -#define MAGIC 0xEF -#define blockReqSize b.reqSize - -/* - * The following defines the minimum and and maximum block sizes and the number - * of buckets in the bucket cache. - */ - -#define MINALLOC ((sizeof(Block) + 8 + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) -#define NBUCKETS (11 - (MINALLOC >> 5)) -#define MAXALLOC (MINALLOC << (NBUCKETS - 1)) - -/* - * The following structure defines a bucket of blocks with various accounting - * and statistics information. - */ - -typedef struct Bucket { - Block *firstPtr; /* First block available */ - long numFree; /* Number of blocks available */ - - /* All fields below for accounting only */ - - long numRemoves; /* Number of removes from bucket */ - long numInserts; /* Number of inserts into bucket */ - long numWaits; /* Number of waits to acquire a lock */ - long numLocks; /* Number of locks acquired */ - long totalAssigned; /* Total space assigned to bucket */ -} Bucket; - -/* - * The following structure defines a cache of buckets and objs, of which there - * will be (at most) one per thread. Any changes need to be reflected in the - * struct AllocCache defined in tclInt.h, possibly also in the initialisation - * code in Tcl_CreateInterp(). - */ - -typedef struct Cache { - struct Cache *nextPtr; /* Linked list of cache entries */ - Tcl_ThreadId owner; /* Which thread's cache is this? */ - Tcl_Obj *firstObjPtr; /* List of free objects for thread */ - int numObjects; /* Number of objects for thread */ - int totalAssigned; /* Total space assigned to thread */ - Bucket buckets[NBUCKETS]; /* The buckets for this thread */ -} Cache; - -/* - * The following array specifies various per-bucket limits and locks. The - * values are statically initialized to avoid calculating them repeatedly. - */ - -static struct { - size_t blockSize; /* Bucket blocksize. */ - int maxBlocks; /* Max blocks before move to share. */ - int numMove; /* Num blocks to move to share. */ - Tcl_Mutex *lockPtr; /* Share bucket lock. */ -} bucketInfo[NBUCKETS]; - -/* - * Static functions defined in this file. - */ - -static Cache * GetCache(void); -static void LockBucket(Cache *cachePtr, int bucket); -static void UnlockBucket(Cache *cachePtr, int bucket); -static void PutBlocks(Cache *cachePtr, int bucket, int numMove); -static int GetBlocks(Cache *cachePtr, int bucket); -static Block * Ptr2Block(char *ptr); -static char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); -static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); - -/* - * Local variables defined in this file and initialized at startup. - */ - -static Tcl_Mutex *listLockPtr; -static Tcl_Mutex *objLockPtr; -static Cache sharedCache; -static Cache *sharedPtr = &sharedCache; -static Cache *firstCachePtr = &sharedCache; - -#if defined(HAVE_FAST_TSD) -static __thread Cache *tcachePtr; - -# define GETCACHE(cachePtr) \ - do { \ - if (!tcachePtr) { \ - tcachePtr = GetCache(); \ - } \ - (cachePtr) = tcachePtr; \ - } while (0) -#else -# define GETCACHE(cachePtr) \ - do { \ - (cachePtr) = TclpGetAllocCache(); \ - if ((cachePtr) == NULL) { \ - (cachePtr) = GetCache(); \ - } \ - } while (0) -#endif - -/* - *---------------------------------------------------------------------- - * - * GetCache --- - * - * Gets per-thread memory cache, allocating it if necessary. - * - * Results: - * Pointer to cache. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Cache * -GetCache(void) -{ - Cache *cachePtr; - - /* - * Check for first-time initialization. - */ - - if (listLockPtr == NULL) { - Tcl_Mutex *initLockPtr; - unsigned int i; - - initLockPtr = Tcl_GetAllocMutex(); - Tcl_MutexLock(initLockPtr); - if (listLockPtr == NULL) { - listLockPtr = TclpNewAllocMutex(); - objLockPtr = TclpNewAllocMutex(); - for (i = 0; i < NBUCKETS; ++i) { - bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); - bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; - bucketInfo[i].lockPtr = TclpNewAllocMutex(); - } - } - Tcl_MutexUnlock(initLockPtr); - } - - /* - * 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"); - } - Tcl_MutexLock(listLockPtr); - cachePtr->nextPtr = firstCachePtr; - firstCachePtr = cachePtr; - Tcl_MutexUnlock(listLockPtr); - cachePtr->owner = Tcl_GetCurrentThread(); - TclpSetAllocCache(cachePtr); - } - return cachePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclFreeAllocCache -- - * - * Flush and delete a cache, removing from list of caches. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclFreeAllocCache( - void *arg) -{ - Cache *cachePtr = arg; - Cache **nextPtrPtr; - register unsigned int bucket; - - /* - * Flush blocks. - */ - - for (bucket = 0; bucket < NBUCKETS; ++bucket) { - if (cachePtr->buckets[bucket].numFree > 0) { - PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].numFree); - } - } - - /* - * Flush objs. - */ - - if (cachePtr->numObjects > 0) { - Tcl_MutexLock(objLockPtr); - MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); - Tcl_MutexUnlock(objLockPtr); - } - - /* - * Remove from pool list. - */ - - Tcl_MutexLock(listLockPtr); - nextPtrPtr = &firstCachePtr; - while (*nextPtrPtr != cachePtr) { - nextPtrPtr = &(*nextPtrPtr)->nextPtr; - } - *nextPtrPtr = cachePtr->nextPtr; - cachePtr->nextPtr = NULL; - Tcl_MutexUnlock(listLockPtr); - free(cachePtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpAlloc -- - * - * Allocate memory. - * - * Results: - * Pointer to memory just beyond Block pointer. - * - * Side effects: - * May allocate more blocks for a bucket. - * - *---------------------------------------------------------------------- - */ - -char * -TclpAlloc( - unsigned int reqSize) -{ - Cache *cachePtr; - Block *blockPtr; - register int bucket; - size_t size; - -#ifndef __LP64__ - 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; - } - } -#endif - - GETCACHE(cachePtr); - - /* - * Increment the requested size to include room for the Block structure. - * Call malloc() directly if the required amount is greater than the - * largest block, otherwise pop the smallest block large enough, - * allocating more blocks if necessary. - */ - - blockPtr = NULL; - size = reqSize + sizeof(Block); -#if RCHECK - size++; -#endif - if (size > MAXALLOC) { - bucket = NBUCKETS; - blockPtr = malloc(size); - if (blockPtr != NULL) { - cachePtr->totalAssigned += reqSize; - } - } else { - bucket = 0; - while (bucketInfo[bucket].blockSize < size) { - bucket++; - } - if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) { - blockPtr = cachePtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock; - cachePtr->buckets[bucket].numFree--; - cachePtr->buckets[bucket].numRemoves++; - cachePtr->buckets[bucket].totalAssigned += reqSize; - } - } - if (blockPtr == NULL) { - return NULL; - } - return Block2Ptr(blockPtr, bucket, reqSize); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFree -- - * - * Return blocks to the thread block cache. - * - * Results: - * None. - * - * Side effects: - * May move blocks to shared cache. - * - *---------------------------------------------------------------------- - */ - -void -TclpFree( - char *ptr) -{ - Cache *cachePtr; - Block *blockPtr; - int bucket; - - if (ptr == NULL) { - return; - } - - GETCACHE(cachePtr); - - /* - * Get the block back from the user pointer and call system free directly - * for large blocks. Otherwise, push the block back on the bucket and move - * blocks to the shared cache if there are now too many free. - */ - - blockPtr = Ptr2Block(ptr); - bucket = blockPtr->sourceBucket; - if (bucket == NBUCKETS) { - cachePtr->totalAssigned -= blockPtr->blockReqSize; - free(blockPtr); - return; - } - - cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; - blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].firstPtr = blockPtr; - cachePtr->buckets[bucket].numFree++; - cachePtr->buckets[bucket].numInserts++; - - if (cachePtr != sharedPtr && - cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { - PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpRealloc -- - * - * Re-allocate memory to a larger or smaller size. - * - * Results: - * Pointer to memory just beyond Block pointer. - * - * Side effects: - * Previous memory, if any, may be freed. - * - *---------------------------------------------------------------------- - */ - -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); - } - -#ifndef __LP64__ - 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; - } - } -#endif - - GETCACHE(cachePtr); - - /* - * 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; -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadAllocObj -- - * - * Allocate a Tcl_Obj from the per-thread cache. - * - * Results: - * Pointer to uninitialized Tcl_Obj. - * - * Side effects: - * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if - * list is empty. - * - * Note: - * If this code is updated, the changes need to be reflected in the macro - * TclAllocObjStorageEx() defined in tclInt.h - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclThreadAllocObj(void) -{ - register Cache *cachePtr; - register Tcl_Obj *objPtr; - - GETCACHE(cachePtr); - - /* - * Get this thread's obj list structure and move or allocate new objs if - * necessary. - */ - - if (cachePtr->numObjects == 0) { - register int numMove; - - Tcl_MutexLock(objLockPtr); - numMove = sharedPtr->numObjects; - if (numMove > 0) { - if (numMove > NOBJALLOC) { - numMove = NOBJALLOC; - } - MoveObjs(sharedPtr, cachePtr, numMove); - } - Tcl_MutexUnlock(objLockPtr); - if (cachePtr->numObjects == 0) { - Tcl_Obj *newObjsPtr; - - cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); - if (newObjsPtr == NULL) { - Tcl_Panic("alloc: could not allocate %d new objects", numMove); - } - while (--numMove >= 0) { - objPtr = &newObjsPtr[numMove]; - objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr; - } - } - } - - /* - * Pop the first object. - */ - - objPtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; - cachePtr->numObjects--; - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadFreeObj -- - * - * Return a free Tcl_Obj to the per-thread cache. - * - * Results: - * None. - * - * Side effects: - * May move free Tcl_Obj's to shared list upon hitting high water mark. - * - * Note: - * If this code is updated, the changes need to be reflected in the macro - * TclAllocObjStorageEx() defined in tclInt.h - * - *---------------------------------------------------------------------- - */ - -void -TclThreadFreeObj( - Tcl_Obj *objPtr) -{ - Cache *cachePtr; - - GETCACHE(cachePtr); - - /* - * Get this thread's list and push on the free Tcl_Obj. - */ - - objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr; - cachePtr->numObjects++; - - /* - * If the number of free objects has exceeded the high water mark, move - * some blocks to the shared list. - */ - - if (cachePtr->numObjects > NOBJHIGH) { - Tcl_MutexLock(objLockPtr); - MoveObjs(cachePtr, sharedPtr, NOBJALLOC); - Tcl_MutexUnlock(objLockPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMemoryInfo -- - * - * Return a list-of-lists of memory stats. - * - * Results: - * None. - * - * Side effects: - * List appended to given dstring. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_GetMemoryInfo( - Tcl_DString *dsPtr) -{ - Cache *cachePtr; - char buf[200]; - unsigned int n; - - Tcl_MutexLock(listLockPtr); - cachePtr = firstCachePtr; - while (cachePtr != NULL) { - Tcl_DStringStartSublist(dsPtr); - if (cachePtr == sharedPtr) { - Tcl_DStringAppendElement(dsPtr, "shared"); - } else { - sprintf(buf, "thread%p", cachePtr->owner); - Tcl_DStringAppendElement(dsPtr, buf); - } - for (n = 0; n < NBUCKETS; ++n) { - sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld", - (unsigned long) bucketInfo[n].blockSize, - cachePtr->buckets[n].numFree, - cachePtr->buckets[n].numRemoves, - cachePtr->buckets[n].numInserts, - cachePtr->buckets[n].totalAssigned, - cachePtr->buckets[n].numLocks, - cachePtr->buckets[n].numWaits); - Tcl_DStringAppendElement(dsPtr, buf); - } - Tcl_DStringEndSublist(dsPtr); - cachePtr = cachePtr->nextPtr; - } - Tcl_MutexUnlock(listLockPtr); -} - -/* - *---------------------------------------------------------------------- - * - * MoveObjs -- - * - * Move Tcl_Obj's between caches. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -MoveObjs( - Cache *fromPtr, - Cache *toPtr, - int numMove) -{ - register Tcl_Obj *objPtr = fromPtr->firstObjPtr; - Tcl_Obj *fromFirstObjPtr = objPtr; - - toPtr->numObjects += numMove; - fromPtr->numObjects -= numMove; - - /* - * 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. - */ - - while (--numMove) { - objPtr = objPtr->internalRep.twoPtrValue.ptr1; - } - fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; - - /* - * Move all objects as a block - they are already linked to each other, we - * just have to update the first and last. - */ - - objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; - toPtr->firstObjPtr = fromFirstObjPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Block2Ptr, Ptr2Block -- - * - * Convert between internal blocks and user pointers. - * - * Results: - * User pointer or internal block. - * - * Side effects: - * Invalid blocks will abort the server. - * - *---------------------------------------------------------------------- - */ - -static char * -Block2Ptr( - Block *blockPtr, - int bucket, - unsigned int reqSize) -{ - register void *ptr; - - blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC; - blockPtr->sourceBucket = bucket; - blockPtr->blockReqSize = reqSize; - ptr = ((void *) (blockPtr + 1)); -#if RCHECK - ((unsigned char *)(ptr))[reqSize] = MAGIC; -#endif - return (char *) ptr; -} - -static Block * -Ptr2Block( - char *ptr) -{ - register Block *blockPtr; - - blockPtr = (((Block *) ptr) - 1); - if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) { - Tcl_Panic("alloc: invalid block: %p: %x %x", - blockPtr, blockPtr->magicNum1, blockPtr->magicNum2); - } -#if RCHECK - if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) { - Tcl_Panic("alloc: invalid block: %p: %x %x %x", - blockPtr, blockPtr->magicNum1, blockPtr->magicNum2, - ((unsigned char *) ptr)[blockPtr->blockReqSize]); - } -#endif - return blockPtr; -} - -/* - *---------------------------------------------------------------------- - * - * LockBucket, UnlockBucket -- - * - * Set/unset the lock to access a bucket in the shared cache. - * - * Results: - * None. - * - * Side effects: - * Lock activity and contention are monitored globally and on a per-cache - * basis. - * - *---------------------------------------------------------------------- - */ - -static void -LockBucket( - Cache *cachePtr, - int bucket) -{ - Tcl_MutexLock(bucketInfo[bucket].lockPtr); - cachePtr->buckets[bucket].numLocks++; - sharedPtr->buckets[bucket].numLocks++; -} - -static void -UnlockBucket( - Cache *cachePtr, - int bucket) -{ - Tcl_MutexUnlock(bucketInfo[bucket].lockPtr); -} - -/* - *---------------------------------------------------------------------- - * - * PutBlocks -- - * - * Return unused blocks to the shared cache. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PutBlocks( - Cache *cachePtr, - int bucket, - int numMove) -{ - register Block *lastPtr, *firstPtr; - register int n = numMove; - - /* - * Before acquiring the lock, walk the block list to find the last block - * to be moved. - */ - - firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; - while (--n > 0) { - lastPtr = lastPtr->nextBlock; - } - cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; - cachePtr->buckets[bucket].numFree -= numMove; - - /* - * Aquire the lock and place the list of blocks at the front of the shared - * cache bucket. - */ - - LockBucket(cachePtr, bucket); - lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; - sharedPtr->buckets[bucket].firstPtr = firstPtr; - sharedPtr->buckets[bucket].numFree += numMove; - UnlockBucket(cachePtr, bucket); -} - -/* - *---------------------------------------------------------------------- - * - * GetBlocks -- - * - * Get more blocks for a bucket. - * - * Results: - * 1 if blocks where allocated, 0 otherwise. - * - * Side effects: - * Cache may be filled with available blocks. - * - *---------------------------------------------------------------------- - */ - -static int -GetBlocks( - Cache *cachePtr, - int bucket) -{ - register Block *blockPtr; - register int n; - - /* - * First, atttempt to move blocks from the shared cache. Note the - * potentially dirty read of numFree before acquiring the lock which is a - * slight performance enhancement. The value is verified after the lock is - * actually acquired. - */ - - if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) { - LockBucket(cachePtr, bucket); - if (sharedPtr->buckets[bucket].numFree > 0) { - - /* - * Either move the entire list or walk the list to find the last - * block to move. - */ - - n = bucketInfo[bucket].numMove; - if (n >= sharedPtr->buckets[bucket].numFree) { - cachePtr->buckets[bucket].firstPtr = - sharedPtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].numFree = - sharedPtr->buckets[bucket].numFree; - sharedPtr->buckets[bucket].firstPtr = NULL; - sharedPtr->buckets[bucket].numFree = 0; - } else { - blockPtr = sharedPtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].firstPtr = blockPtr; - sharedPtr->buckets[bucket].numFree -= n; - cachePtr->buckets[bucket].numFree = n; - while (--n > 0) { - blockPtr = blockPtr->nextBlock; - } - sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; - blockPtr->nextBlock = NULL; - } - } - UnlockBucket(cachePtr, bucket); - } - - if (cachePtr->buckets[bucket].numFree == 0) { - register size_t size; - - /* - * If no blocks could be moved from shared, first look for a larger - * block in this cache to split up. - */ - - blockPtr = NULL; - n = NBUCKETS; - size = 0; /* lint */ - while (--n > bucket) { - if (cachePtr->buckets[n].numFree > 0) { - size = bucketInfo[n].blockSize; - blockPtr = cachePtr->buckets[n].firstPtr; - cachePtr->buckets[n].firstPtr = blockPtr->nextBlock; - cachePtr->buckets[n].numFree--; - break; - } - } - - /* - * Otherwise, allocate a big new block directly. - */ - - if (blockPtr == NULL) { - size = MAXALLOC; - blockPtr = malloc(size); - if (blockPtr == NULL) { - return 0; - } - } - - /* - * Split the larger block into smaller blocks for this bucket. - */ - - n = size / bucketInfo[bucket].blockSize; - cachePtr->buckets[bucket].numFree = n; - cachePtr->buckets[bucket].firstPtr = blockPtr; - while (--n > 0) { - blockPtr->nextBlock = (Block *) - ((char *) blockPtr + bucketInfo[bucket].blockSize); - blockPtr = blockPtr->nextBlock; - } - blockPtr->nextBlock = NULL; - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeThreadAlloc -- - * - * This procedure is used to destroy all private resources used in this - * file. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeThreadAlloc(void) -{ - unsigned int i; - - for (i = 0; i < NBUCKETS; ++i) { - TclpFreeAllocMutex(bucketInfo[i].lockPtr); - bucketInfo[i].lockPtr = NULL; - } - - TclpFreeAllocMutex(objLockPtr); - objLockPtr = NULL; - - TclpFreeAllocMutex(listLockPtr); - listLockPtr = NULL; - - TclpFreeAllocCache(NULL); -} - -#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */ -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMemoryInfo -- - * - * Return a list-of-lists of memory stats. - * - * Results: - * None. - * - * Side effects: - * List appended to given dstring. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_GetMemoryInfo( - Tcl_DString *dsPtr) -{ - Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use"); -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeThreadAlloc -- - * - * This procedure is used to destroy all private resources used in this - * file. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeThreadAlloc(void) -{ - Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use"); -} -#endif /* TCL_THREADS && USE_THREAD_ALLOC */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclTrace.c ================================================================== --- generic/tclTrace.c +++ generic/tclTrace.c @@ -1677,11 +1677,11 @@ /* * Copy the command characters into a new string. */ - commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1); + commandCopy = ckalloc((unsigned) numChars + 1); memcpy(commandCopy, command, (size_t) numChars); commandCopy[numChars] = '\0'; /* * Call the trace function then free allocated storage. @@ -1688,11 +1688,11 @@ */ traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr, iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); - TclStackFree(interp, commandCopy); + ckfree(commandCopy); return traceCode; } /* *---------------------------------------------------------------------- @@ -2265,11 +2265,11 @@ /* * This is a bit messy because we have to emulate the old trace interface, * which uses strings for everything. */ - argv = (const char **) TclStackAlloc(interp, + argv = (const char **) ckalloc( (unsigned) ((objc + 1) * sizeof(const char *))); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -2280,11 +2280,11 @@ * either command or argv. */ data->proc(data->clientData, interp, level, (char *) command, cmdPtr->proc, cmdPtr->clientData, objc, argv); - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); return TCL_OK; } /* ADDED normBench Index: normBench ================================================================== --- /dev/null +++ normBench @@ -0,0 +1,666 @@ +TCL_INTERP: 1:8.6b1.2 2:8.6b1.2 3:8.6b1.2 4:8.6b1.2 5:8.6b1.2 6:8.6b1.2 7:8.6b1.2 8:8.5.9 +STARTED 2011-03-28 10:53:26 (runbench.tcl v1.30) +Benchmark 1:8.6b1.2 /home/mig/tcl/branch.base/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:12 elapsed +Benchmark 2:8.6b1.2 /home/mig/tcl/branch.multi/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:08 elapsed +Benchmark 3:8.6b1.2 /home/mig/tcl/branch.native/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:13 elapsed +Benchmark 4:8.6b1.2 /home/mig/tcl/branch.tsd/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:08 elapsed +Benchmark 5:8.6b1.2 /home/mig/tcl/no280.tsd/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:07 elapsed +Benchmark 6:8.6b1.2 /home/mig/tcl/trunk.base/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:10 elapsed +Benchmark 7:8.6b1.2 /home/mig/tcl/trunk.tsd/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:07 elapsed +Benchmark 8:8.5.9 /home/mig/tcl/core8.5/unix/tclsh +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:09 elapsed +R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 +000 VERSIONS: 1:8.6b1.2 2:8.6b1.2 3:8.6b1.2 4:8.6b1.2 5:8.6b1.2 6:8.6b1.2 7:8.6b1.2 8:8.5.9 +001 ARRAY format genKeys 50 0.94 0.79 0.96 0.87 0.77 0.91 0.82 1.00 +002 ARRAY format genKeys 500 0.92 0.80 0.95 0.87 0.77 0.91 0.82 1.00 +003 ARRAY makeHash 500 50 0.93 0.89 0.79 0.89 0.83 0.95 0.90 1.00 +004 ascii85 strlen 2690 1.00 0.95 1.00 0.93 0.94 0.94 0.92 1.00 +005 ascii85 strlen 269000 0.97 0.94 0.97 0.91 0.92 0.93 0.90 1.00 +006 BASE64 decode 10 1.04 0.95 1.04 0.96 0.88 1.03 0.95 1.00 +007 BASE64 decode 100 1.07 0.95 1.05 0.99 0.89 1.05 0.96 1.00 +008 BASE64 decode 1000 1.08 0.96 1.05 0.99 0.89 1.04 0.98 1.00 +009 BASE64 decode 10000 1.06 0.98 1.03 0.98 0.89 1.04 0.96 1.00 +010 BASE64 decode2 10 1.05 0.95 1.05 0.97 0.88 1.02 0.95 1.00 +011 BASE64 decode2 100 1.07 0.99 1.05 1.00 0.89 1.06 0.98 1.00 +012 BASE64 decode2 1000 1.06 0.99 1.04 1.00 0.90 1.05 0.98 1.00 +013 BASE64 decode2 10000 1.05 0.98 1.03 0.99 0.89 1.03 0.96 1.00 +014 BASE64 decode3 10 1.07 1.00 1.07 0.99 0.90 1.04 0.97 1.00 +015 BASE64 decode3 100 1.04 0.99 1.03 0.96 0.89 1.03 0.97 1.00 +016 BASE64 decode3 1000 1.02 1.00 1.02 0.96 0.90 1.03 0.97 1.00 +017 BASE64 decode3 10000 1.02 1.00 1.02 0.95 0.91 1.03 0.98 1.00 +018 BASE64 encode 10 1.07 1.00 1.09 1.06 0.97 1.05 1.02 1.00 +019 BASE64 encode 100 1.07 1.02 1.05 1.08 1.00 1.04 1.03 1.00 +020 BASE64 encode 1000 1.07 1.04 1.05 1.08 1.00 1.05 1.04 1.00 +021 BASE64 encode 10000 1.07 1.04 1.06 1.09 1.00 1.05 1.04 1.00 +022 BASE64 encode2 10 1.08 1.02 1.09 1.06 0.95 1.06 1.02 1.00 +023 BASE64 encode2 100 1.09 1.07 1.07 1.11 1.02 1.09 1.07 1.00 +024 BASE64 encode2 1000 1.10 1.07 1.07 1.11 1.02 1.09 1.07 1.00 +025 BASE64 encode2 10000 1.10 1.08 1.07 1.15 1.02 1.09 1.08 1.00 +026 BASE64 encode3 10 1.07 0.99 1.09 1.00 0.94 1.03 0.97 1.00 +027 BASE64 encode3 100 1.06 1.04 1.07 1.04 0.99 1.05 1.00 1.00 +028 BASE64 encode3 1000 1.06 1.03 1.04 1.04 0.99 1.04 1.01 1.00 +029 BASE64 encode3 10000 1.07 1.03 1.04 1.07 0.99 1.05 1.03 1.00 +030 BIN bitset-v1 1000 chars 1.60 1.46 1.44 1.41 1.31 1.43 1.31 1.00 +031 BIN bitset-v1 5000 chars 1.62 1.50 1.44 1.44 1.31 1.41 1.35 1.00 +032 BIN bitset-v1 10000 chars 1.62 1.50 1.44 1.44 1.32 1.43 1.33 1.00 +033 BIN bitset-v2 1000 chars 1.31 1.19 1.19 1.18 1.08 1.15 1.10 1.00 +034 BIN bitset-v2 5000 chars 1.29 1.18 1.15 1.18 1.07 1.14 1.09 1.00 +035 BIN bitset-v2 10000 chars 1.29 1.17 1.15 1.18 1.07 1.13 1.08 1.00 +036 BIN bitset-v3 1000 chars 0.88 0.81 0.86 0.83 0.65 0.88 0.82 1.00 +037 BIN bitset-v3 5000 chars 0.88 0.80 0.84 0.83 0.65 0.86 0.80 1.00 +038 BIN bitset-v3 10000 chars 0.88 0.80 0.83 0.83 0.65 0.87 0.83 1.00 +039 BIN c scan, 1000b 0.93 0.88 1.04 0.88 0.81 0.95 0.90 1.00 +040 BIN c scan, 5000b 0.95 0.93 0.97 0.93 0.93 0.96 0.96 1.00 +041 BIN c scan, 10000b 0.96 0.96 1.00 0.94 0.96 0.96 0.96 1.00 +042 BIN chars, 10000b 0.87 0.80 0.82 0.81 0.72 0.87 0.81 1.00 +043 BIN rand string 100b 1.34 1.21 1.27 1.17 1.39 1.19 1.14 1.00 +044 BIN rand string 5000b 1.36 1.24 1.29 1.18 1.42 1.21 1.16 1.00 +045 BIN rand2 string 100b 1.24 1.14 1.06 1.13 1.29 1.08 1.05 1.00 +046 BIN rand2 string 5000b 1.24 1.14 1.04 1.13 1.36 1.07 1.05 1.00 +047 BIN u char, 10000b 0.94 0.94 0.97 0.95 0.97 0.99 0.97 1.00 +048 CATCH error, complex 1.08 0.98 1.15 0.96 0.92 1.04 0.98 1.00 +049 CATCH no catch used 1.41 1.19 1.44 1.16 1.27 1.11 1.06 1.00 +050 CATCH return error 1.07 0.96 1.13 0.95 0.92 1.04 0.96 1.00 +051 CATCH return except 1.39 1.20 1.44 1.18 1.26 1.11 1.06 1.00 +052 CATCH return ok 1.40 1.24 1.50 1.20 1.25 1.12 1.08 1.00 +053 DATA access in a list 1.08 1.08 1.13 1.02 1.06 1.09 1.13 1.00 +054 DATA access in an array 1.06 1.06 1.18 1.04 1.07 1.10 1.08 1.00 +055 DATA create in a list 1.04 1.02 1.01 0.99 0.79 1.02 1.04 1.00 +056 DATA create in an array 1.02 0.96 1.17 0.97 0.87 1.05 1.01 1.00 +057 ENC iso2022-jp, gets 1.12 1.00 0.99 1.00 1.04 1.10 0.95 1.00 +058 ENC iso2022-jp, read 1.12 1.00 0.97 0.99 0.93 1.06 0.91 1.00 +059 ENC iso2022-jp, read & size 0.96 0.86 0.83 0.86 0.80 0.90 0.79 1.00 +060 ENC iso8859-2, gets 0.37 0.35 0.39 0.35 0.35 0.36 0.34 1.00 +061 ENC iso8859-2, read 0.25 0.25 0.27 0.25 0.25 0.25 0.25 1.00 +062 ENC iso8859-2, read & size 0.28 0.27 0.30 0.28 0.27 0.28 0.27 1.00 +063 EVAL cmd and mixed lists 0.81 0.75 1.09 0.75 0.64 0.83 0.77 1.00 +064 EVAL cmd eval as list 1.46 1.24 1.42 1.22 1.06 1.24 1.10 1.00 +065 EVAL cmd eval as string 1.03 0.92 1.11 0.93 0.75 0.93 0.85 1.00 +066 EVAL cmd eval in list obj var 1.43 1.19 1.32 1.19 1.06 1.19 1.08 1.00 +067 EVAL cmd eval in list obj {*} 1.52 1.31 1.61 1.31 1.25 1.36 1.26 1.00 +068 EVAL list cmd and mixed lists 0.84 0.79 1.12 0.78 0.65 0.83 0.78 1.00 +069 EVAL list cmd and pure lists 1.01 0.89 0.99 0.98 0.93 0.91 1.01 1.00 +070 EXPR $a != $b dbl 1.60 1.43 1.83 1.45 1.40 1.38 1.38 1.00 +071 EXPR $a != $b int 1.55 1.32 1.68 1.35 1.30 1.25 1.20 1.00 +072 EXPR $a != $b str (!= len) 1.14 1.00 1.16 1.05 0.94 0.98 0.95 1.00 +073 EXPR $a != $b str (== len) 1.23 1.08 1.27 1.13 1.03 1.09 1.03 1.00 +074 EXPR $a == $b dbl 1.57 1.45 1.83 1.48 1.40 1.38 1.33 1.00 +075 EXPR $a == $b int 1.56 1.36 1.69 1.44 1.36 1.26 1.23 1.00 +076 EXPR $a == $b str (!= len) 1.15 1.01 1.16 1.07 0.97 0.95 0.98 1.00 +077 EXPR $a == $b str (== len) 1.27 1.10 1.26 1.15 1.06 1.06 1.05 1.00 +078 EXPR abs as expr 1.69 1.50 1.94 1.53 1.58 1.44 1.36 1.00 +079 EXPR abs builtin 1.67 1.44 1.81 1.47 1.51 1.37 1.28 1.00 +080 EXPR braced 1.42 1.26 1.40 1.23 1.36 1.25 1.16 1.00 +081 EXPR builtin dyn 1.11 1.03 1.25 1.00 0.80 1.04 0.98 1.00 +082 EXPR builtin sin 1.67 1.42 1.63 1.35 1.46 1.27 1.21 1.00 +083 EXPR cast double 1.68 1.38 1.79 1.40 1.51 1.32 1.26 1.00 +084 EXPR cast int 1.79 1.52 1.67 1.54 1.42 1.31 1.23 1.00 +085 EXPR fifty operands 1.05 0.96 1.15 0.94 0.96 0.95 0.92 1.00 +086 EXPR incr with expr 1.65 1.39 1.87 1.35 1.32 1.23 1.19 1.00 +087 EXPR incr with incr 1.71 1.43 1.93 1.43 1.39 1.32 1.25 1.00 +088 EXPR inline 1.28 1.21 1.18 1.21 1.22 1.21 1.13 1.00 +089 EXPR one operand 1.75 1.46 2.04 1.54 1.39 1.32 1.29 1.00 +090 EXPR rand range 1.71 1.49 1.61 1.49 1.58 1.34 1.28 1.00 +091 EXPR rand range func 1.77 1.47 1.67 1.48 1.48 1.31 1.24 1.00 +092 EXPR ten operands 1.33 1.18 1.53 1.16 1.14 1.12 1.04 1.00 +093 EXPR unbraced 1.03 0.97 1.25 0.95 0.81 0.98 0.96 1.00 +094 EXPR unbraced long 0.89 0.86 1.04 0.86 0.81 0.91 0.93 1.00 +095 EXPR UpdStrOfDbl+1.23 prec0 1.18 1.01 1.28 1.05 1.03 1.03 1.00 1.00 +096 EXPR UpdStrOfDbl+1.23 prec12 1.28 1.09 1.29 1.11 1.13 1.07 1.02 1.00 +097 EXPR UpdStrOfDbl+1.23 prec17 1.15 1.04 1.19 1.06 1.08 1.05 1.01 1.00 +098 EXPR UpdStrOfDbl+1e-4 prec0 1.15 1.00 1.22 1.01 1.05 1.03 0.98 1.00 +099 EXPR UpdStrOfDbl+1e-4 prec12 1.27 1.08 1.28 1.12 1.14 1.08 1.02 1.00 +100 EXPR UpdStrOfDbl+1e-4 prec17 1.14 1.01 1.17 1.06 1.06 1.04 0.98 1.00 +101 EXPR UpdStrOfDbl+1e27 prec0 0.98 0.89 1.14 0.88 0.91 0.93 0.87 1.00 +102 EXPR UpdStrOfDbl+1e27 prec12 1.29 1.10 1.31 1.10 1.11 1.08 1.00 1.00 +103 EXPR UpdStrOfDbl+1e27 prec17 0.99 0.90 1.14 0.89 0.92 0.98 0.92 1.00 +104 FCOPY binary: 160K 1.01 1.02 1.02 1.02 1.02 1.01 1.03 1.00 +105 FCOPY encoding: 160K 0.90 0.90 0.86 0.90 0.95 0.94 0.86 1.00 +106 FCOPY std: 160K 1.02 1.02 1.01 1.02 1.02 1.03 1.03 1.00 +107 FILE exec interp 1.08 1.06 1.15 1.08 1.61 1.13 1.07 1.00 +108 FILE exec interp: pkg require 1.04 1.03 1.10 1.03 1.20 1.05 1.03 1.00 +109 FILE exists tmpfile (obj) 1.29 1.23 1.23 1.25 1.16 1.19 1.18 1.00 +110 FILE exists ~ 1.32 1.20 1.23 1.24 1.15 1.18 1.15 1.00 +111 FILE exists! tmpfile (obj) 1.30 1.27 1.22 1.28 1.18 1.22 1.20 1.00 +112 FILE exists! tmpfile (str) 1.12 1.08 1.06 1.05 1.01 1.07 1.05 1.00 +113 FILE glob tmpdir (60 entries) 0.93 0.94 1.02 0.91 0.88 0.94 0.90 1.00 +114 FILE glob / all subcommands 1.07 1.04 1.07 1.05 1.00 1.07 1.02 1.00 +115 FILE glob / atime 1.02 0.98 1.02 0.97 0.91 0.98 0.94 1.00 +116 FILE glob / attributes 0.98 0.96 1.00 0.98 0.95 0.98 0.97 1.00 +117 FILE glob / dirname 1.25 1.20 1.28 1.19 1.10 1.23 1.13 1.00 +118 FILE glob / executable 1.03 0.98 1.01 0.97 0.92 0.99 0.96 1.00 +119 FILE glob / exists 1.04 1.00 1.04 0.99 0.93 1.01 0.98 1.00 +120 FILE glob / extension 1.19 1.14 1.26 1.12 1.05 1.20 1.06 1.00 +121 FILE glob / isdirectory 1.06 1.01 1.06 1.01 0.93 1.02 0.98 1.00 +122 FILE glob / isfile 1.05 1.02 1.06 1.00 0.93 1.01 0.98 1.00 +123 FILE glob / mtime 1.05 1.01 1.08 1.00 0.93 1.05 0.99 1.00 +124 FILE glob / owned 1.05 1.00 1.07 1.00 0.92 1.03 0.98 1.00 +125 FILE glob / readable 1.03 1.00 1.05 0.99 0.93 1.00 0.97 1.00 +126 FILE glob / rootname 1.19 1.13 1.23 1.11 1.04 1.18 1.06 1.00 +127 FILE glob / size 1.02 1.01 1.05 0.99 0.93 1.00 0.96 1.00 +128 FILE glob / tail 1.25 1.20 1.29 1.19 1.11 1.25 1.12 1.00 +129 FILE glob / writable 1.02 1.02 1.05 0.99 0.93 1.01 0.97 1.00 +130 FILE recurse / -dir 1.03 1.01 1.10 0.99 0.95 1.04 0.98 1.00 +131 FILE recurse / cd 1.06 1.03 1.13 1.03 0.99 1.07 1.01 1.00 +132 FORMAT gen 1.16 0.98 1.26 0.99 0.98 1.02 0.97 1.00 +133 GCCont_cpb::cGCC 50 0.93 0.90 0.92 0.88 0.76 0.92 0.85 1.00 +134 GCCont_cpb::cGCC 500 0.89 0.89 0.83 0.88 0.73 0.90 0.84 1.00 +135 GCCont_cpb::cGCC 5000 0.87 0.86 0.80 0.86 0.71 0.88 0.81 1.00 +136 GCCont_cpbre1::cGCC 50 1.03 1.01 0.97 1.00 0.94 1.02 1.00 1.00 +137 GCCont_cpbre1::cGCC 500 1.02 1.02 0.97 1.00 0.98 1.01 1.00 1.00 +138 GCCont_cpbre1::cGCC 5000 1.02 1.01 0.97 0.99 0.99 0.99 0.99 1.00 +139 GCCont_cpbre2::cGCC 50 1.02 1.00 0.97 0.97 0.94 0.99 0.96 1.00 +140 GCCont_cpbre2::cGCC 500 1.03 1.03 0.98 0.99 1.00 1.00 0.99 1.00 +141 GCCont_cpbre2::cGCC 5000 1.02 1.03 0.98 0.99 1.00 1.00 1.00 1.00 +142 GCCont_cpbrs2::cGCC 50 0.97 0.91 0.98 0.89 0.83 0.91 0.84 1.00 +143 GCCont_cpbrs2::cGCC 500 0.83 0.83 0.86 0.83 0.81 0.81 0.82 1.00 +144 GCCont_cpbrs2::cGCC 5000 0.80 0.81 0.80 0.81 0.81 0.78 0.82 1.00 +145 GCCont_cpbrs::cGCC1 50 0.99 0.96 0.98 0.92 0.88 0.98 0.96 1.00 +146 GCCont_cpbrs::cGCC1 500 0.89 0.88 0.89 0.87 0.85 0.87 0.88 1.00 +147 GCCont_cpbrs::cGCC1 5000 0.86 0.86 0.85 0.86 0.85 0.84 0.87 1.00 +148 GCCont_cpbrs::cGCC2 50 0.98 0.94 0.95 0.91 0.85 0.95 0.93 1.00 +149 GCCont_cpbrs::cGCC2 500 0.85 0.84 0.85 0.82 0.80 0.83 0.84 1.00 +150 GCCont_cpbrs::cGCC2 5000 0.80 0.80 0.80 0.80 0.80 0.78 0.81 1.00 +151 GCCont_cpbrs_trap::cGCC 50 1.01 0.99 0.98 0.97 0.94 1.04 0.99 1.00 +152 GCCont_cpbrs_trap::cGCC 500 1.01 1.01 0.97 0.98 0.97 1.03 0.98 1.00 +153 GCCont_cpbrs_trap::cGCC 5000 1.00 1.00 0.96 0.98 0.97 1.02 0.99 1.00 +154 GCCont_expr::cGCC 50 0.95 0.91 1.12 0.91 0.82 0.94 0.94 1.00 +155 GCCont_expr::cGCC 500 0.87 0.85 1.00 0.86 0.78 0.90 0.91 1.00 +156 GCCont_expr::cGCC 5000 0.87 0.86 0.95 0.86 0.78 0.90 0.93 1.00 +157 GCCont_i::cGCC1 50 0.95 0.92 0.94 0.91 0.83 0.97 0.90 1.00 +158 GCCont_i::cGCC1 500 0.92 0.89 0.91 0.88 0.81 0.95 0.95 1.00 +159 GCCont_i::cGCC1 5000 0.91 0.88 0.90 0.89 0.80 0.95 0.95 1.00 +160 GCCont_i::cGCC2 50 0.95 0.91 0.93 0.90 0.82 0.93 0.88 1.00 +161 GCCont_i::cGCC2 500 0.92 0.90 0.89 0.90 0.82 0.93 0.88 1.00 +162 GCCont_i::cGCC2 5000 0.92 0.90 0.89 0.90 0.81 0.94 0.88 1.00 +163 GCCont_i::cGCC3 50 0.95 0.88 0.93 0.87 0.79 0.94 0.87 1.00 +164 GCCont_i::cGCC3 500 0.90 0.84 0.88 0.84 0.77 0.92 0.86 1.00 +165 GCCont_i::cGCC3 5000 0.90 0.84 0.87 0.84 0.75 0.92 0.86 1.00 +166 GCCont_r1::cGCC 50 1.10 1.06 1.13 1.07 1.10 1.08 1.06 1.00 +167 GCCont_r1::cGCC 500 1.11 1.07 1.14 1.10 1.11 1.12 1.07 1.00 +168 GCCont_r1::cGCC 5000 1.12 1.07 1.14 1.10 1.11 1.11 1.08 1.00 +169 GCCont_r2::cGCC 50 1.02 0.96 1.04 0.97 0.89 1.02 0.95 1.00 +170 GCCont_r2::cGCC 500 0.99 0.95 1.03 0.96 0.92 1.02 1.01 1.00 +171 GCCont_r2::cGCC 5000 0.98 0.93 1.01 0.96 0.90 0.98 0.99 1.00 +172 GCCont_r3::cGCC 50 1.02 0.98 1.05 0.98 0.90 1.02 0.95 1.00 +173 GCCont_r3::cGCC 500 1.00 0.95 1.03 0.97 0.94 1.00 1.00 1.00 +174 GCCont_r3::cGCC 5000 0.98 0.94 1.01 0.96 0.92 1.00 1.00 1.00 +175 GCCont_rsf1::cGCC 50 0.94 0.88 0.94 0.87 0.78 0.94 0.89 1.00 +176 GCCont_rsf1::cGCC 500 0.88 0.82 0.85 0.82 0.73 0.89 0.84 1.00 +177 GCCont_rsf1::cGCC 5000 0.85 0.81 0.82 0.80 0.71 0.87 0.81 1.00 +178 GCCont_rsf2::cGCC1 50 0.98 0.93 0.98 0.91 0.84 0.98 0.92 1.00 +179 GCCont_rsf2::cGCC1 500 0.89 0.86 0.87 0.85 0.76 0.89 0.86 1.00 +180 GCCont_rsf2::cGCC1 5000 0.87 0.84 0.83 0.84 0.74 0.88 0.84 1.00 +181 GCCont_rsf2::cGCC2 50 0.99 0.93 1.01 0.91 0.84 0.96 0.91 1.00 +182 GCCont_rsf2::cGCC2 500 0.88 0.84 0.87 0.84 0.75 0.89 0.85 1.00 +183 GCCont_rsf2::cGCC2 5000 0.87 0.82 0.83 0.83 0.73 0.87 0.83 1.00 +184 GCCont_rsf3::cGCC 50 0.98 0.93 0.99 0.90 0.84 0.97 0.90 1.00 +185 GCCont_rsf3::cGCC 500 0.89 0.85 0.87 0.84 0.75 0.89 0.85 1.00 +186 GCCont_rsf3::cGCC 5000 0.87 0.81 0.83 0.83 0.73 0.87 0.83 1.00 +187 GCCont_turing::cGCC 50 0.90 0.85 0.93 0.85 0.80 0.82 0.80 1.00 +188 GCCont_turing::cGCC 500 0.72 0.70 0.72 0.71 0.69 0.70 0.70 1.00 +189 GCCont_turing::cGCC 5000 0.67 0.69 0.68 0.67 0.65 0.66 0.67 1.00 +190 HEAPSORT size 10 1.03 1.03 1.08 1.04 1.01 1.02 1.01 1.00 +191 HEAPSORT size 50 1.02 1.01 1.06 1.03 0.98 1.02 0.99 1.00 +192 HEAPSORT size 100 1.01 1.00 1.04 1.01 0.97 1.01 0.98 1.00 +193 HEAPSORT2 size 10 1.10 1.09 1.10 1.10 1.06 1.06 1.06 1.00 +194 HEAPSORT2 size 50 1.09 1.08 1.05 1.09 1.06 1.06 1.05 1.00 +195 HEAPSORT2 size 100 1.10 1.09 1.05 1.09 1.06 1.07 1.06 1.00 +196 IF 1/0 check 1.51 1.29 1.80 1.31 1.26 1.23 1.14 1.00 +197 IF else true al 1.41 1.24 1.48 1.31 1.24 1.23 1.20 1.00 +198 IF else true numeric 1.55 1.33 1.65 1.41 1.29 1.25 1.22 1.00 +199 IF elseif true al 1.32 1.22 1.39 1.24 1.20 1.15 1.15 1.00 +200 IF elseif true numeric 1.50 1.31 1.65 1.35 1.27 1.25 1.17 1.00 +201 IF if false al/al 1.50 1.29 1.57 1.34 1.30 1.23 1.21 1.00 +202 IF if false al/num 1.54 1.28 1.65 1.40 1.30 1.21 1.21 1.00 +203 IF if false num/num 1.55 1.32 1.84 1.41 1.30 1.23 1.20 1.00 +204 IF if true al 1.46 1.30 1.61 1.31 1.28 1.19 1.17 1.00 +205 IF if true al/al 1.46 1.29 1.57 1.29 1.25 1.14 1.14 1.00 +206 IF if true num/num 1.58 1.37 1.74 1.40 1.33 1.23 1.21 1.00 +207 IF if true numeric 1.57 1.40 1.86 1.45 1.33 1.26 1.24 1.00 +208 IF multi 1st true 1.55 1.32 1.75 1.39 1.32 1.27 1.25 1.00 +209 IF multi 2nd true 1.52 1.33 1.73 1.40 1.33 1.27 1.25 1.00 +210 IF multi 9th true 1.36 1.23 1.44 1.27 1.21 1.19 1.15 1.00 +211 IF multi default true 1.41 1.24 1.52 1.32 1.24 1.20 1.18 1.00 +212 KLIST shuffle0 llength 1 0.95 0.93 1.00 0.88 0.82 0.95 0.90 1.00 +213 KLIST shuffle0 llength 10 0.95 0.91 0.93 0.88 0.76 0.96 0.86 1.00 +214 KLIST shuffle0 llength 100 0.93 0.86 0.91 0.86 0.76 0.95 0.86 1.00 +215 KLIST shuffle0 llength 1000 0.94 0.88 0.92 0.88 0.79 0.95 0.88 1.00 +216 KLIST shuffle0 llength 10000 0.95 0.90 0.92 0.90 0.90 0.98 0.93 1.00 +217 KLIST shuffle1-s llength 1 1.36 1.23 1.34 1.19 1.22 1.13 1.09 1.00 +218 KLIST shuffle1-s llength 10 1.29 1.21 1.27 1.15 1.21 1.12 1.06 1.00 +219 KLIST shuffle1-s llength 100 1.15 1.10 1.28 1.06 1.10 1.12 0.99 1.00 +220 KLIST shuffle1-s llength 1000 1.02 1.00 1.11 1.01 0.95 1.01 0.91 1.00 +221 KLIST shuffle1a llength 1 1.48 1.33 1.53 1.29 1.35 1.21 1.15 1.00 +222 KLIST shuffle1a llength 10 1.54 1.38 1.55 1.35 1.44 1.25 1.19 1.00 +223 KLIST shuffle1a llength 100 1.56 1.37 1.56 1.35 1.45 1.26 1.20 1.00 +224 KLIST shuffle1a llength 1000 1.53 1.36 1.53 1.36 1.45 1.25 1.21 1.00 +225 KLIST shuffle1a llength 10000 1.54 1.37 1.56 1.37 1.46 1.26 1.22 1.00 +226 KLIST shuffle2 llength 1 1.24 1.14 1.26 1.13 1.13 1.06 1.05 1.00 +227 KLIST shuffle2 llength 10 1.22 1.12 1.24 1.12 1.13 1.09 1.08 1.00 +228 KLIST shuffle2 llength 100 1.24 1.13 1.26 1.13 1.14 1.11 1.10 1.00 +229 KLIST shuffle2 llength 1000 1.19 1.11 1.21 1.12 1.10 1.11 1.09 1.00 +230 KLIST shuffle2 llength 10000 1.16 1.10 1.12 1.09 1.08 1.08 1.07 1.00 +231 KLIST shuffle3 llength 1 1.42 1.29 1.43 1.25 1.24 1.15 1.09 1.00 +232 KLIST shuffle3 llength 10 1.54 1.37 1.50 1.38 1.47 1.24 1.20 1.00 +233 KLIST shuffle3 llength 100 1.55 1.38 1.49 1.39 1.49 1.25 1.21 1.00 +234 KLIST shuffle3 llength 1000 1.54 1.36 1.48 1.39 1.45 1.22 1.20 1.00 +235 KLIST shuffle3 llength 10000 1.24 1.17 1.24 1.18 1.22 1.09 1.05 1.00 +236 KLIST shuffle4 llength 1 1.36 1.23 1.38 1.21 1.21 1.13 1.07 1.00 +237 KLIST shuffle4 llength 10 1.52 1.36 1.48 1.34 1.43 1.24 1.19 1.00 +238 KLIST shuffle4 llength 100 1.54 1.38 1.50 1.38 1.47 1.25 1.21 1.00 +239 KLIST shuffle4 llength 1000 1.56 1.40 1.50 1.41 1.48 1.26 1.22 1.00 +240 KLIST shuffle4 llength 10000 1.55 1.37 1.46 1.36 1.47 1.26 1.21 1.00 +241 KLIST shuffle5-s llength 1 1.34 1.16 1.29 1.16 1.12 1.09 1.02 1.00 +242 KLIST shuffle5-s llength 10 1.30 1.21 1.28 1.14 1.19 1.09 1.04 1.00 +243 KLIST shuffle5-s llength 100 1.27 1.18 1.22 1.11 1.15 1.08 1.02 1.00 +244 KLIST shuffle5-s llength 1000 1.07 1.02 1.04 1.01 0.97 0.98 0.93 1.00 +245 KLIST shuffle5a llength 1 1.40 1.25 1.43 1.22 1.20 1.14 1.07 1.00 +246 KLIST shuffle5a llength 10 1.44 1.33 1.46 1.28 1.31 1.18 1.13 1.00 +247 KLIST shuffle5a llength 100 1.46 1.35 1.42 1.30 1.35 1.19 1.14 1.00 +248 KLIST shuffle5a llength 1000 1.45 1.34 1.46 1.29 1.34 1.20 1.16 1.00 +249 KLIST shuffle5a llength 10000 1.21 1.20 1.22 1.17 1.17 1.10 1.09 1.00 +250 KLIST shuffle6 llength 1 1.35 1.14 1.44 1.19 0.95 1.02 0.98 1.00 +251 KLIST shuffle6 llength 10 1.26 1.21 1.19 1.17 1.25 1.16 1.11 1.00 +252 KLIST shuffle6 llength 100 1.27 1.23 1.20 1.17 1.28 1.17 1.14 1.00 +253 KLIST shuffle6 llength 1000 1.26 1.22 1.20 1.19 1.29 1.17 1.15 1.00 +254 KLIST shuffle6 llength 10000 1.30 1.25 1.19 1.23 1.31 1.20 1.17 1.00 +255 LIST append to list 1.38 1.20 1.60 1.18 1.13 1.07 1.00 1.00 +256 LIST concat APPEND 2x10 0.94 0.82 1.08 0.82 0.69 0.92 0.84 1.00 +257 LIST concat APPEND 2x100 0.85 0.76 1.15 0.76 0.60 0.88 0.77 1.00 +258 LIST concat APPEND 2x1000 0.85 0.77 1.09 0.77 0.64 0.89 0.79 1.00 +259 LIST concat APPEND 2x10000 0.85 0.78 1.06 0.78 0.65 0.89 0.79 1.00 +260 LIST concat CONCAT 2x10 1.20 1.13 1.32 1.08 1.07 1.09 1.02 1.00 +261 LIST concat CONCAT 2x100 1.15 1.08 1.27 1.06 1.06 1.06 1.02 1.00 +262 LIST concat CONCAT 2x1000 0.99 1.01 0.99 0.97 0.97 0.96 0.99 1.00 +263 LIST concat CONCAT 2x10000 0.90 0.92 1.03 0.92 1.01 0.96 1.02 1.00 +264 LIST concat EVAL/LAPPEND 2x10 1.19 1.06 1.19 1.05 0.92 1.06 0.98 1.00 +265 LIST concat EVAL/LAPPEND 2x100 1.13 1.06 1.21 1.05 0.94 1.06 1.01 1.00 +266 LIST concat EVAL/LAPPEND 2x1000 1.13 1.10 0.99 1.11 1.00 1.11 1.14 1.00 +267 LIST concat EVAL/LAPPEND 2x10000 0.89 0.89 0.98 0.87 0.96 0.95 0.99 1.00 +268 LIST concat FOREACH/LAPPEND 2x10 0.97 0.90 0.93 0.88 0.75 0.91 0.84 1.00 +269 LIST concat FOREACH/LAPPEND 2x100 0.89 0.81 0.81 0.80 0.67 0.88 0.81 1.00 +270 LIST concat FOREACH/LAPPEND 2x1000 0.91 0.81 0.81 0.81 0.66 0.89 0.81 1.00 +271 LIST concat FOREACH/LAPPEND 2x10000 0.88 0.77 0.80 0.79 0.64 0.88 0.80 1.00 +272 LIST concat SET 2x10 0.91 0.82 1.06 0.80 0.67 0.92 0.82 1.00 +273 LIST concat SET 2x100 0.81 0.72 1.14 0.72 0.57 0.87 0.76 1.00 +274 LIST concat SET 2x1000 0.83 0.74 1.07 0.73 0.62 0.87 0.76 1.00 +275 LIST concat SET 2x10000 0.85 0.76 1.08 0.76 0.63 0.87 0.78 1.00 +276 LIST exact search, first item 1.76 1.38 1.64 1.44 1.40 1.36 1.24 1.00 +277 LIST exact search, last item 1.22 1.12 1.21 1.15 1.19 1.16 1.13 1.00 +278 LIST exact search, middle item 1.38 1.18 1.31 1.20 1.24 1.24 1.16 1.00 +279 LIST exact search, non-item 1.13 1.10 1.13 1.10 1.13 1.15 1.14 1.00 +280 LIST exact search, typed item 0.90 0.87 0.92 0.89 0.92 0.99 0.90 1.00 +281 LIST exact search, untyped item 1.21 1.11 1.20 1.12 1.16 1.13 1.10 1.00 +282 LIST index first element 1.69 1.31 1.82 1.31 1.28 1.33 1.18 1.00 +283 LIST index last element 1.64 1.28 1.90 1.31 1.28 1.31 1.18 1.00 +284 LIST index middle element 1.67 1.31 1.74 1.31 1.28 1.31 1.18 1.00 +285 LIST insert an item at "end" 0.96 0.94 0.98 0.86 1.02 0.99 0.89 1.00 +286 LIST insert an item at middle 0.94 0.93 0.96 0.85 1.00 0.98 0.88 1.00 +287 LIST insert an item at start 0.95 0.92 0.97 0.85 1.03 1.03 0.88 1.00 +288 LIST iterate list 1.10 1.08 1.01 1.06 0.99 1.14 1.09 1.00 +289 LIST join list 1.22 1.21 1.22 1.21 1.23 1.22 1.21 1.00 +290 LIST large, early range 1.23 1.06 1.31 1.06 1.07 1.03 1.01 1.00 +291 LIST large, late range 1.25 1.06 1.31 1.05 1.07 1.05 1.01 1.00 +292 LIST length, pure list 1.50 1.29 1.81 1.29 1.14 1.21 1.10 1.00 +293 LIST list 0.96 0.84 0.91 0.85 0.73 0.96 0.83 1.00 +294 LIST lset foreach l 1.07 1.02 1.09 0.98 0.85 0.98 0.97 1.00 +295 LIST lset foreach list 1.04 0.98 1.11 0.97 0.84 0.98 0.98 1.00 +296 LIST lset foreach ""s l 0.97 0.90 0.88 0.92 0.78 0.97 0.90 1.00 +297 LIST lset foreach ""s list 0.99 0.94 0.91 0.94 0.80 0.98 0.91 1.00 +298 LIST regexp search, first item 1.65 1.35 1.64 1.38 1.35 1.31 1.18 1.00 +299 LIST regexp search, last item 1.03 0.99 1.01 1.00 0.98 1.00 0.99 1.00 +300 LIST regexp search, non-item 1.00 0.95 0.98 0.96 0.96 0.99 0.97 1.00 +301 LIST remove first element 0.98 1.04 1.01 0.96 1.02 0.97 0.90 1.00 +302 LIST remove in mixed list 1.20 1.28 1.11 1.27 0.84 1.06 1.08 1.00 +303 LIST remove last element 0.96 1.02 1.01 0.95 1.01 0.96 0.89 1.00 +304 LIST remove middle element 0.88 0.90 0.89 0.79 0.88 0.86 0.80 1.00 +305 LIST replace first el with multiple 0.95 0.99 1.00 0.94 1.02 0.96 0.89 1.00 +306 LIST replace first element 0.89 0.89 0.90 0.80 0.89 0.90 0.82 1.00 +307 LIST replace in mixed list 1.13 1.14 1.12 1.12 0.85 1.09 1.05 1.00 +308 LIST replace last el with multiple 0.90 0.92 0.94 0.90 0.96 0.90 0.81 1.00 +309 LIST replace last element 0.85 0.90 0.93 0.80 0.88 0.89 0.83 1.00 +310 LIST replace middle el with multiple 0.89 0.89 0.93 0.82 0.92 0.93 0.86 1.00 +311 LIST replace middle element 0.95 0.96 0.99 0.91 0.96 0.93 0.84 1.00 +312 LIST replace range 1.35 1.15 1.48 1.15 1.27 1.20 1.18 1.00 +313 LIST reverse core 1.01 1.00 1.10 0.99 1.15 0.99 0.96 1.00 +314 LIST reverse lappend 1.08 1.06 1.12 1.08 1.12 1.06 1.12 1.00 +315 LIST small, early range 1.37 1.12 1.29 1.12 1.11 1.09 1.05 1.00 +316 LIST small, late range 1.35 1.12 1.32 1.09 1.08 1.06 1.03 1.00 +317 LIST sort 1.01 1.01 1.02 1.01 1.02 1.01 1.01 1.00 +318 LIST sorted search, first item 1.58 1.30 1.53 1.33 1.37 1.30 1.18 1.00 +319 LIST sorted search, last item 1.57 1.28 1.52 1.33 1.33 1.28 1.20 1.00 +320 LIST sorted search, middle item 1.54 1.28 1.51 1.30 1.34 1.26 1.16 1.00 +321 LIST sorted search, non-item 1.59 1.31 1.54 1.36 1.36 1.31 1.17 1.00 +322 LIST sorted search, typed item 1.61 1.32 1.51 1.36 1.32 1.25 1.14 1.00 +323 LIST typed sort 1.10 1.08 1.11 1.12 1.09 1.09 1.06 1.00 +324 LOOP for (to 1000) 1.21 1.16 1.25 1.19 1.12 1.18 1.18 1.00 +325 LOOP for, iterate list 1.09 1.04 1.19 1.02 1.11 1.15 1.14 1.00 +326 LOOP for, iterate string 1.01 0.94 1.05 0.94 1.04 1.03 0.96 1.00 +327 LOOP foreach, iterate list 0.80 0.71 0.71 0.71 0.60 0.90 0.73 1.00 +328 LOOP foreach, iterate string 0.81 0.72 0.74 0.73 0.62 0.87 0.74 1.00 +329 LOOP while (to 1000) 1.22 1.17 1.28 1.19 1.12 1.19 1.19 1.00 +330 LOOP while 1 (to 1000) 1.17 1.15 1.18 1.18 1.13 1.23 1.13 1.00 +331 MAP ([chars])-case regsub 1.01 0.99 0.98 0.97 0.96 1.00 0.98 1.00 +332 MAP http mapReply 1.03 1.04 1.05 1.00 0.96 1.06 1.05 1.00 +333 MAP regsub -nocase, no match 0.99 1.11 1.01 0.99 1.02 0.98 0.97 1.00 +334 MAP regsub 1 val 0.49 0.58 0.46 0.50 0.50 0.49 0.50 1.00 +335 MAP regsub 1 val -nocase 0.73 0.82 0.71 0.74 0.74 0.71 0.72 1.00 +336 MAP regsub 2 val 0.48 0.52 0.45 0.49 0.46 0.45 0.47 1.00 +337 MAP regsub 2 val -nocase 0.67 0.73 0.63 0.65 0.64 0.64 0.65 1.00 +338 MAP regsub 3 val 0.45 0.49 0.43 0.45 0.43 0.43 0.44 1.00 +339 MAP regsub 3 val -nocase 0.66 0.72 0.62 0.65 0.63 0.62 0.64 1.00 +340 MAP regsub 4 val 0.44 0.49 0.43 0.45 0.42 0.42 0.43 1.00 +341 MAP regsub 4 val -nocase 0.64 0.71 0.62 0.63 0.62 0.61 0.62 1.00 +342 MAP regsub short 0.96 0.90 1.04 0.91 0.83 0.82 0.84 1.00 +343 MAP regsub, no match 1.00 1.50 1.00 0.99 0.99 1.00 1.00 1.00 +344 MAP string -nocase, no match 0.82 0.82 0.82 0.83 0.81 0.82 0.82 1.00 +345 MAP string 1 val 0.42 0.42 0.39 0.43 0.42 0.41 0.41 1.00 +346 MAP string 1 val -nocase 0.65 0.65 0.67 0.71 0.67 0.70 0.70 1.00 +347 MAP string 2 val 0.67 0.67 0.71 0.70 0.67 0.66 0.67 1.00 +348 MAP string 2 val -nocase 0.80 0.80 0.78 0.80 0.79 0.79 0.79 1.00 +349 MAP string 3 val 0.70 0.70 0.73 0.75 0.71 0.70 0.71 1.00 +350 MAP string 3 val -nocase 0.83 0.83 0.82 0.83 0.82 0.82 0.84 1.00 +351 MAP string 4 val 0.68 0.66 0.71 0.72 0.69 0.69 0.72 1.00 +352 MAP string 4 val -nocase 0.82 0.83 0.83 0.83 0.83 0.82 0.82 1.00 +353 MAP string short 1.02 0.92 1.04 0.91 0.82 0.87 0.84 1.00 +354 MAP string, no match 0.65 0.65 0.74 0.66 0.63 0.64 0.64 1.00 +355 MAP |-case regsub 1.01 1.01 0.96 0.96 0.97 1.01 0.99 1.00 +356 MAP |-case strmap 1.16 1.06 1.22 1.01 0.93 1.02 0.97 1.00 +357 MATRIX mult 5x5 0.84 0.77 0.83 0.75 0.65 0.85 0.77 1.00 +358 MATRIX mult 10x10 0.83 0.75 0.80 0.73 0.63 0.85 0.75 1.00 +359 MATRIX mult 15x15 0.82 0.73 0.79 0.73 0.62 0.84 0.74 1.00 +360 MATRIX transposition-0 1.02 1.11 1.12 0.99 0.98 1.04 1.06 1.00 +361 MATRIX transposition-1 1.03 1.00 1.06 1.00 1.01 1.04 1.01 1.00 +362 MD5 msg len 10 1.14 1.01 1.12 1.00 0.99 1.00 0.95 1.00 +363 MD5 msg len 100 1.17 1.04 1.15 1.02 1.01 1.01 0.95 1.00 +364 MD5 msg len 1000 1.10 0.98 1.13 0.97 0.99 0.99 0.91 1.00 +365 MD5 msg len 10000 0.99 0.88 1.15 0.86 0.93 0.96 0.88 1.00 +366 MTHD array stored proc call 1.46 1.21 1.56 1.23 1.10 1.17 1.13 1.00 +367 MTHD call absolute 1.80 1.46 1.88 1.45 1.47 1.31 1.27 1.00 +368 MTHD call relative 1.67 1.36 1.71 1.36 1.41 1.27 1.22 1.00 +369 MTHD direct ns proc call 1.61 1.32 1.84 1.32 1.29 1.23 1.16 1.00 +370 MTHD imported ns proc call 1.87 1.48 1.97 1.48 1.42 1.35 1.29 1.00 +371 MTHD indirect proc eval 1.29 1.07 1.32 1.05 0.98 1.05 0.97 1.00 +372 MTHD indirect proc eval #2 1.36 1.15 1.44 1.12 0.99 1.11 1.02 1.00 +373 MTHD inline call 1.40 1.27 1.40 1.20 1.13 1.27 1.20 1.00 +374 MTHD interp alias proc call 2.08 1.74 2.18 1.72 1.44 1.56 1.51 1.00 +375 MTHD ns lookup call 1.19 1.05 1.18 1.02 0.92 1.08 0.99 1.00 +376 MTHD switch method call 1.30 1.10 1.40 1.14 1.01 1.09 0.99 1.00 +377 NS alternating 1.12 0.96 1.20 0.95 0.98 1.02 0.93 1.00 +378 PARSE html form upload (7978) 1.27 1.16 1.17 1.18 1.13 1.17 1.10 1.00 +379 PARSE html form upload (993570) 1.27 1.15 1.16 1.18 1.12 1.18 1.08 1.00 +380 PROC do-nothing, no args 1.83 1.54 1.92 1.50 1.50 1.42 1.38 1.00 +381 PROC do-nothing, one arg 1.81 1.50 1.96 1.50 1.46 1.38 1.31 1.00 +382 PROC empty, no args 1.75 1.50 2.12 1.50 1.38 1.38 1.38 1.00 +383 PROC empty, use args 1.75 1.50 1.88 1.50 1.38 1.38 1.38 1.00 +384 PROC explicit return 1.70 1.44 1.93 1.48 1.41 1.30 1.26 1.00 +385 PROC explicit return (2) 1.74 1.44 2.15 1.48 1.41 1.30 1.26 1.00 +386 PROC explicit return (3) 1.74 1.44 1.93 1.48 1.41 1.30 1.26 1.00 +387 PROC heavily commented 1.81 1.50 2.08 1.54 1.46 1.35 1.31 1.00 +388 PROC implicit return 1.79 1.46 2.18 1.50 1.43 1.32 1.32 1.00 +389 PROC implicit return (2) 1.78 1.48 2.07 1.52 1.44 1.33 1.30 1.00 +390 PROC implicit return (3) 1.81 1.50 2.00 1.54 1.50 1.35 1.31 1.00 +391 PROC local links with global 1.07 1.06 1.13 1.05 1.05 1.06 1.04 1.00 +392 PROC local links with upvar 1.06 1.05 1.13 1.04 1.04 1.04 1.04 1.00 +393 PROC local links with variable 1.06 1.06 1.11 1.06 1.05 1.04 1.04 1.00 +394 RE 1-char long-end 1.05 1.03 1.03 1.03 1.02 1.04 1.02 1.00 +395 RE 1-char long-end catching 1.03 1.00 1.02 0.99 0.97 1.01 1.00 1.00 +396 RE 1-char long-middle 1.09 1.06 1.06 1.05 1.03 1.06 1.04 1.00 +397 RE 1-char long-middle catching 1.05 1.00 1.02 0.99 0.96 1.01 0.99 1.00 +398 RE 1-char long-start 1.35 1.21 1.26 1.23 1.12 1.23 1.15 1.00 +399 RE 1-char long-start catching 1.08 0.98 1.02 0.97 0.93 1.01 0.99 1.00 +400 RE 1-char short 1.36 1.20 1.23 1.22 1.13 1.21 1.15 1.00 +401 RE 1-char short catching 1.07 0.97 1.03 0.97 0.91 1.00 0.97 1.00 +402 RE basic 1.38 1.19 1.28 1.19 1.13 1.24 1.16 1.00 +403 RE basic catching 1.06 0.98 1.06 0.98 0.94 1.01 1.01 1.00 +404 RE c-comment long 1.04 1.01 1.07 1.01 1.00 1.02 1.01 1.00 +405 RE c-comment long catching 1.01 0.99 1.04 0.99 0.98 1.00 1.00 1.00 +406 RE c-comment long nomatch 1.02 1.01 1.04 1.01 1.00 1.01 1.00 1.00 +407 RE c-comment long nomatch catching 1.03 1.01 1.05 1.02 1.01 1.02 1.01 1.00 +408 RE c-comment long pmatch 1.02 1.01 1.04 1.01 1.00 1.01 1.00 1.00 +409 RE c-comment long pmatch catching 1.03 1.01 1.04 1.02 1.01 1.02 1.01 1.00 +410 RE c-comment many *s 1.02 1.01 1.04 1.01 1.01 1.02 1.01 1.00 +411 RE c-comment many *s catching 1.01 1.00 1.02 1.00 0.99 1.01 1.00 1.00 +412 RE c-comment nomatch 1.23 1.08 1.37 1.08 1.02 1.13 1.05 1.00 +413 RE c-comment nomatch catching 1.25 1.10 1.37 1.12 1.04 1.15 1.07 1.00 +414 RE c-comment simple 1.12 1.05 1.17 1.05 1.02 1.08 1.04 1.00 +415 RE c-comment simple catching 1.03 0.97 1.05 0.98 0.95 0.99 0.98 1.00 +416 RE count all matches 1.04 1.01 1.01 1.02 1.02 1.01 1.00 1.00 +417 RE extract all matches 0.97 0.92 0.95 0.92 0.91 0.96 0.94 1.00 +418 RE ini file 1.00 1.00 1.00 1.00 1.00 1.00 1.00 1.00 +419 RE ini file ng 1.00 1.00 1.00 1.00 1.00 1.00 1.00 1.00 +420 RE literal regexp 1.25 1.18 1.18 1.14 1.11 1.20 1.15 1.00 +421 RE n-char long-end 1.05 1.03 1.04 1.03 1.02 1.03 1.02 1.00 +422 RE n-char long-end catching 1.03 0.99 1.01 0.99 0.97 0.99 0.99 1.00 +423 RE n-char long-middle 1.09 1.05 1.07 1.05 1.03 1.05 1.04 1.00 +424 RE n-char long-middle catching 1.04 0.97 1.01 0.98 0.95 0.98 0.98 1.00 +425 RE n-char long-start 1.31 1.19 1.26 1.18 1.11 1.20 1.13 1.00 +426 RE n-char long-start catching 1.08 0.97 1.01 0.97 0.92 0.98 0.97 1.00 +427 RE n-char short 1.34 1.20 1.25 1.19 1.13 1.20 1.15 1.00 +428 RE n-char short catching 1.06 0.96 1.00 0.96 0.90 0.97 0.97 1.00 +429 RE static anchored match 1.63 1.37 1.83 1.37 1.33 1.27 1.20 1.00 +430 RE static anchored match dot 1.66 1.38 1.78 1.41 1.34 1.25 1.19 1.00 +431 RE static anchored nomatch 1.67 1.37 1.83 1.40 1.33 1.27 1.20 1.00 +432 RE static anchored nomatch dot 1.79 1.46 2.00 1.50 1.46 1.32 1.29 1.00 +433 RE static l-anchored match 1.70 1.40 1.87 1.43 1.37 1.30 1.23 1.00 +434 RE static l-anchored nomatch 1.79 1.46 2.00 1.50 1.46 1.36 1.32 1.00 +435 RE static long match 1.40 1.28 1.56 1.41 1.25 1.38 1.36 1.00 +436 RE static long nomatch 1.00 0.94 1.14 1.07 0.93 1.05 1.04 1.00 +437 RE static r-anchored match 1.68 1.42 1.84 1.42 1.39 1.29 1.26 1.00 +438 RE static r-anchored nomatch 1.66 1.38 1.81 1.44 1.38 1.31 1.25 1.00 +439 RE static short match 1.68 1.42 1.87 1.42 1.39 1.29 1.29 1.00 +440 RE static short nomatch 1.73 1.43 1.97 1.47 1.43 1.33 1.37 1.00 +441 RE var ***= directive match 1.13 1.00 1.25 1.10 0.99 1.13 1.07 1.00 +442 RE var ***= directive nomatch 1.11 1.00 1.26 1.10 0.99 1.11 1.06 1.00 +443 RE var . match 1.53 1.29 1.61 1.31 1.27 1.37 1.24 1.00 +444 RE var [0-9] match 1.21 1.13 1.14 1.12 1.07 1.14 1.10 1.00 +445 RE var \d match 1.25 1.15 1.15 1.15 1.07 1.15 1.10 1.00 +446 RE var ^$ nomatch 1.54 1.29 1.65 1.31 1.27 1.33 1.23 1.00 +447 RE var backtrack case 1.15 1.09 1.10 1.08 1.04 1.10 1.07 1.00 +448 RE var-based regexp 1.21 1.18 1.14 1.11 1.10 1.19 1.15 1.00 +449 READ 595K, cat 1.04 1.00 1.02 1.00 1.00 1.02 0.94 1.00 +450 READ 595K, gets 1.00 0.92 0.97 0.94 0.93 0.96 0.88 1.00 +451 READ 595K, glob-grep match 1.07 0.93 1.02 1.00 0.93 0.97 0.90 1.00 +452 READ 595K, glob-grep nomatch 1.05 0.93 0.99 1.00 0.92 0.99 0.91 1.00 +453 READ 595K, read 1.02 1.00 0.91 1.00 0.97 0.92 0.92 1.00 +454 READ 595K, read & size 0.88 0.86 0.78 0.85 0.89 0.78 0.79 1.00 +455 READ 595K, read dyn buf 1.00 0.98 0.89 0.98 0.93 0.90 0.90 1.00 +456 READ 595K, read small buf 1.03 1.09 1.05 1.04 1.04 1.08 1.04 1.00 +457 READ 3050b, cat 1.02 0.98 1.02 0.97 0.99 1.00 0.93 1.00 +458 READ 3050b, gets 1.00 0.93 0.97 0.94 0.92 0.96 0.88 1.00 +459 READ 3050b, glob-grep match 1.06 0.94 1.01 1.01 0.94 0.97 0.91 1.00 +460 READ 3050b, glob-grep nomatch 1.04 0.92 1.00 0.99 0.94 0.99 0.90 1.00 +461 READ 3050b, read 1.10 0.97 0.98 0.98 0.92 0.93 0.92 1.00 +462 READ 3050b, read & size 0.97 0.87 0.87 0.87 0.81 0.83 0.83 1.00 +463 READ 3050b, read dyn buf 1.06 0.98 0.99 0.97 0.94 0.93 0.93 1.00 +464 READ 3050b, read small buf 1.04 1.03 1.04 1.02 1.05 1.10 1.04 1.00 +465 READ bin 595K, cat 1.15 1.08 1.09 1.03 1.14 1.12 1.03 1.00 +466 READ bin 595K, gets 1.06 0.96 1.01 0.93 1.02 1.04 0.96 1.00 +467 READ bin 595K, glob-grep match 1.18 1.00 1.07 1.09 1.05 1.08 1.02 1.00 +468 READ bin 595K, glob-grep nomatch 1.23 1.03 1.04 1.07 1.09 1.17 1.03 1.00 +469 READ bin 595K, read 1.00 1.00 1.01 1.00 0.98 1.00 1.00 1.00 +470 READ bin 595K, read & size 0.99 1.00 0.99 1.00 0.98 1.00 0.99 1.00 +471 READ bin 595K, read dyn buf 1.01 1.01 1.01 1.01 0.99 1.01 1.00 1.00 +472 READ bin 595K, read small buf 1.00 1.04 1.04 1.03 1.02 1.03 1.04 1.00 +473 READ bin 3050b, cat 1.09 1.04 1.08 0.98 1.09 1.08 0.99 1.00 +474 READ bin 3050b, gets 1.06 0.97 1.02 0.94 1.02 1.04 0.97 1.00 +475 READ bin 3050b, glob-grep match 1.05 0.94 1.08 0.99 0.98 1.01 0.94 1.00 +476 READ bin 3050b, glob-grep nomatch 1.05 0.92 1.03 0.98 0.97 1.05 0.94 1.00 +477 READ bin 3050b, read 1.01 0.98 1.08 0.99 0.97 1.02 0.97 1.00 +478 READ bin 3050b, read & size 1.04 1.00 1.09 1.01 0.97 1.04 0.97 1.00 +479 READ bin 3050b, read dyn buf 1.01 1.00 1.08 1.01 1.01 1.03 0.99 1.00 +480 READ bin 3050b, read small buf 1.04 1.06 1.09 1.05 1.05 1.06 1.08 1.00 +481 SHA1 msg len 10 1.09 1.02 1.05 1.00 1.01 1.04 0.99 1.00 +482 SHA1 msg len 100 1.10 1.03 1.06 1.01 1.02 1.05 1.00 1.00 +483 SHA1 msg len 1000 1.11 1.05 1.08 1.03 1.05 1.08 1.02 1.00 +484 SHA1 msg len 10000 1.11 1.05 1.07 1.03 1.05 1.07 1.01 1.00 +485 SPLIT iter, 4000 uchars 0.83 0.77 0.79 0.77 0.67 0.85 0.79 1.00 +486 SPLIT iter, 4010 chars 0.82 0.76 0.78 0.76 0.65 0.84 0.79 1.00 +487 SPLIT iter, rand 100 c 0.85 0.75 1.02 0.75 0.63 0.86 0.76 1.00 +488 SPLIT iter, rand 1000 c 0.85 0.76 0.86 0.77 0.65 0.86 0.78 1.00 +489 SPLIT iter, rand 10000 c 0.86 0.79 0.81 0.79 0.68 0.87 0.80 1.00 +490 SPLIT on 'c', 4000 uchars 0.86 0.77 0.87 0.78 0.62 0.89 0.79 1.00 +491 SPLIT on 'c', 4010 chars 0.85 0.76 0.86 0.77 0.61 0.89 0.79 1.00 +492 SPLIT on 'cz', 4000 uchars 0.91 0.84 0.92 0.83 0.72 0.94 0.86 1.00 +493 SPLIT on 'cz', 4010 chars 0.89 0.82 0.90 0.83 0.71 0.92 0.85 1.00 +494 SPLIT on 'cū', 4000 uchars 0.92 0.88 0.92 0.85 0.83 1.02 0.96 1.00 +495 SPLIT on 'cū', 4010 chars 0.95 0.91 0.94 0.89 0.93 1.07 1.02 1.00 +496 SPLIT, 4000 uchars 0.95 0.94 1.00 0.94 0.98 0.98 0.98 1.00 +497 SPLIT, 4010 chars 0.96 0.93 0.99 0.93 0.95 0.96 0.96 1.00 +498 SPLIT, rand 100 c 0.89 0.77 1.32 0.78 0.68 0.91 0.82 1.00 +499 SPLIT, rand 1000 c 0.90 0.83 1.10 0.83 0.78 0.92 0.86 1.00 +500 SPLIT, rand 10000 c 0.96 0.93 1.02 0.93 0.93 0.95 0.94 1.00 +501 STR append 1.15 1.07 1.14 1.03 0.82 0.96 0.96 1.00 +502 STR append (1KB + 1KB) 1.23 1.04 1.38 1.08 0.93 1.03 0.96 1.00 +503 STR append (1MB + (1b+1K+1b)*100) 1.03 1.02 1.02 1.02 1.02 1.04 1.04 1.00 +504 STR append (1MB + 1KB) 1.00 1.00 1.00 1.00 0.99 1.02 1.03 1.00 +505 STR append (1MB + 1KB*20) 1.00 1.00 1.00 1.01 1.00 1.02 1.03 1.00 +506 STR append (1MB + 1KB*1000) 1.07 1.05 1.06 1.06 1.07 1.06 1.08 1.00 +507 STR append (1MB + 1MB*3) 1.00 1.00 1.00 1.00 1.00 1.01 1.01 1.00 +508 STR append (1MB + 1MB*5) 1.00 1.00 1.00 1.00 1.00 1.01 1.01 1.00 +509 STR append (1MB + 2b*1000) 1.06 1.05 1.07 1.06 1.07 1.04 1.05 1.00 +510 STR append (10KB + 1KB) 1.17 1.10 1.02 1.10 0.91 0.98 0.97 1.00 +511 STR first (failure) 1.05 1.03 1.08 1.03 0.83 1.04 1.03 1.00 +512 STR first (failure) utf 1.06 1.04 1.07 1.05 0.84 1.05 1.06 1.00 +513 STR first (success) 1.54 1.34 1.51 1.34 1.35 1.32 1.28 1.00 +514 STR first (success) utf 1.53 1.31 1.49 1.32 1.32 1.31 1.27 1.00 +515 STR first (total failure) 1.10 1.06 1.10 1.06 0.79 1.06 1.05 1.00 +516 STR first (total failure) utf 1.10 1.07 1.10 1.06 0.79 1.06 1.05 1.00 +517 STR index 0 1.36 1.17 1.41 1.14 1.16 1.16 1.07 1.00 +518 STR index 100 1.39 1.18 1.42 1.16 1.16 1.18 1.09 1.00 +519 STR index 500 1.39 1.18 1.42 1.16 1.18 1.16 1.07 1.00 +520 STR info locals match 1.05 1.05 1.08 1.03 1.01 1.04 1.03 1.00 +521 STR last (failure) 1.06 1.04 1.05 1.03 0.89 1.04 1.03 1.00 +522 STR last (success) 1.57 1.33 1.50 1.32 1.35 1.33 1.29 1.00 +523 STR last (total failure) 1.07 1.04 1.07 1.04 0.86 1.04 1.04 1.00 +524 STR length (==4010) 1.52 1.27 1.65 1.27 1.22 1.20 1.15 1.00 +525 STR length growing (1000) 1.16 1.06 1.10 1.14 1.10 1.13 1.14 1.00 +526 STR length growing uc (1000) 1.18 1.07 1.07 1.13 1.09 1.11 1.15 1.00 +527 STR length of a LIST 1.55 1.32 1.63 1.29 1.24 1.24 1.16 1.00 +528 STR length static str 1.72 1.41 1.93 1.45 1.41 1.31 1.28 1.00 +529 STR match, complex (failure) 0.89 0.89 1.04 1.02 0.87 1.01 1.01 1.00 +530 STR match, complex (success early) 1.50 1.26 1.59 1.30 1.22 1.24 1.17 1.00 +531 STR match, complex (success late) 0.93 0.96 1.05 1.02 0.87 1.02 1.01 1.00 +532 STR match, complex (total failure) 0.85 0.83 1.04 1.02 0.83 1.02 1.01 1.00 +533 STR match, exact (failure) 1.70 1.37 1.87 1.40 1.37 1.23 1.20 1.00 +534 STR match, exact (success) 1.70 1.33 1.73 1.40 1.33 1.23 1.20 1.00 +535 STR match, exact -nocase (failure) 1.76 1.41 1.83 1.48 1.41 1.31 1.28 1.00 +536 STR match, exact -nocase (success) 1.49 1.29 1.62 1.29 1.27 1.18 1.16 1.00 +537 STR match, recurse (fail backtrack) 1.01 1.01 1.02 1.01 1.01 1.01 1.01 1.00 +538 STR match, recurse (fail bt1) 1.01 1.01 1.02 1.01 1.01 1.01 1.01 1.00 +539 STR match, recurse (fail bt2) 1.02 1.01 1.03 1.02 1.01 1.01 1.01 1.00 +540 STR match, recurse (fail ranchor) 0.80 0.80 1.00 1.00 0.80 1.00 1.00 1.00 +541 STR match, recurse (success bt2) 1.11 1.07 1.15 1.09 1.06 1.07 1.04 1.00 +542 STR match, recurse2 (fail) 0.85 0.86 1.00 1.00 0.85 1.00 1.00 1.00 +543 STR match, recurse2 (success) 0.89 0.90 1.04 1.02 0.87 1.01 1.01 1.00 +544 STR match, simple (failure) 1.73 1.43 1.87 1.47 1.43 1.30 1.30 1.00 +545 STR match, simple (success) 1.68 1.42 1.90 1.45 1.39 1.29 1.29 1.00 +546 STR range, index 100..200 of 4010 1.40 1.22 1.40 1.20 1.20 1.20 1.15 1.00 +547 STR repeat, 4010 chars * 10 1.09 1.04 1.09 1.01 0.98 1.03 1.03 1.00 +548 STR repeat, 4010 chars * 100 1.02 1.01 1.02 1.01 1.01 1.01 1.01 1.00 +549 STR repeat, abcdefghij * 10 1.62 1.42 1.66 1.41 1.38 1.38 1.34 1.00 +550 STR repeat, abcdefghij * 100 1.38 1.25 1.44 1.30 1.21 1.22 1.21 1.00 +551 STR repeat, abcdefghij * 1000 1.07 1.05 1.08 1.19 1.04 1.04 1.04 1.00 +552 STR replace, equal replacement 1.26 1.17 1.26 1.15 1.09 1.14 1.13 1.00 +553 STR replace, longer replacement 1.16 1.08 1.09 1.09 0.97 1.09 1.07 1.00 +554 STR replace, no replacement 1.54 1.41 1.34 1.31 1.16 1.14 1.08 1.00 +555 STR reverse core, 10 c 1.45 1.26 1.52 1.27 1.25 1.26 1.21 1.00 +556 STR reverse core, 10 uc 1.40 1.22 1.48 1.24 1.22 1.22 1.17 1.00 +557 STR reverse core, 100 c 1.43 1.24 1.47 1.28 1.23 1.25 1.23 1.00 +558 STR reverse core, 100 uc 1.42 1.25 1.47 1.27 1.20 1.25 1.19 1.00 +559 STR reverse core, 400 c 1.29 1.13 1.42 1.22 1.11 1.16 1.20 1.00 +560 STR reverse core, 400 uc 1.41 1.22 1.50 1.32 1.18 1.22 1.27 1.00 +561 STR reverse iter/append, 10 c 1.10 0.99 1.27 0.99 1.06 1.05 0.98 1.00 +562 STR reverse iter/append, 10 uc 1.08 0.96 1.21 0.99 1.04 1.03 0.96 1.00 +563 STR reverse iter/append, 100 c 1.09 1.02 1.15 1.02 1.12 1.13 1.01 1.00 +564 STR reverse iter/append, 100 uc 1.05 1.01 1.10 0.97 1.05 1.09 0.98 1.00 +565 STR reverse iter/append, 400 c 1.09 1.05 1.12 1.02 1.14 1.14 1.02 1.00 +566 STR reverse iter/append, 400 uc 1.03 1.00 1.09 0.98 1.06 1.09 0.98 1.00 +567 STR reverse iter/set, 10 c 1.13 0.99 1.18 1.00 1.09 1.10 1.05 1.00 +568 STR reverse iter/set, 10 uc 1.10 0.98 1.19 0.99 1.09 1.08 1.03 1.00 +569 STR reverse iter/set, 100 c 1.07 1.00 1.16 0.99 1.11 1.10 1.02 1.00 +570 STR reverse iter/set, 100 uc 1.04 0.98 1.12 0.97 1.09 1.08 1.00 1.00 +571 STR reverse iter/set, 400 c 1.05 0.97 1.23 0.98 1.10 1.10 1.01 1.00 +572 STR reverse iter/set, 400 uc 1.03 0.95 1.22 0.95 1.07 1.07 0.99 1.00 +573 STR reverse recursive, 10 c 1.23 1.11 1.20 1.03 1.08 1.07 0.99 1.00 +574 STR reverse recursive, 10 uc 1.26 1.14 1.24 1.07 1.10 1.10 1.02 1.00 +575 STR reverse recursive, 100 c 1.22 1.11 1.22 1.05 1.07 1.05 0.98 1.00 +576 STR reverse recursive, 100 uc 1.25 1.13 1.25 1.07 1.09 1.08 1.00 1.00 +577 STR reverse recursive, 400 c 1.23 1.09 1.21 1.04 1.05 1.03 0.95 1.00 +578 STR reverse recursive, 400 uc 1.23 1.10 1.22 1.05 1.06 1.04 0.96 1.00 +579 STR str $a eq $b 1.40 1.19 1.46 1.26 1.16 1.16 1.11 1.00 +580 STR str $a eq $b (same obj) 1.39 1.19 1.49 1.22 1.17 1.11 1.07 1.00 +581 STR str $a equal "" 1.62 1.38 1.70 1.45 1.40 1.30 1.28 1.00 +582 STR str $a ne $b 1.42 1.22 1.46 1.26 1.18 1.15 1.11 1.00 +583 STR str $a ne $b (same obj) 1.36 1.19 1.44 1.24 1.16 1.13 1.09 1.00 +584 STR str num == "" 1.52 1.29 1.62 1.37 1.29 1.21 1.17 1.00 +585 STR strcmp bin long eq 1.20 1.16 1.19 1.15 1.11 1.14 1.11 1.00 +586 STR strcmp bin long neq 1.20 1.15 1.25 1.15 1.10 1.14 1.11 1.00 +587 STR strcmp bin long neqS 1.44 1.32 1.48 1.30 1.24 1.30 1.24 1.00 +588 STR strcmp bin short eq 1.67 1.50 1.64 1.45 1.37 1.44 1.38 1.00 +589 STR streq bin long eq 0.06 0.06 0.06 0.06 0.06 0.06 0.06 1.00 +590 STR streq bin long neq 0.06 0.06 0.06 0.06 0.06 0.06 0.06 1.00 +591 STR streq bin long neqS 0.04 0.04 0.04 0.04 0.03 0.03 0.03 1.00 +592 STR streq bin short eq 1.01 0.93 1.03 0.91 0.84 0.88 0.85 1.00 +593 STR string compare 1.44 1.15 1.47 1.18 1.11 1.17 1.06 1.00 +594 STR string compare "" 1.35 1.18 1.42 1.19 1.15 1.08 1.06 1.00 +595 STR string compare long 1.16 1.08 1.16 1.09 1.06 1.07 1.04 1.00 +596 STR string compare long (same obj) 1.36 1.15 1.44 1.22 1.17 1.19 1.08 1.00 +597 STR string compare mixed long 1.02 1.01 0.97 0.94 1.02 0.95 0.94 1.00 +598 STR string compare uni long 0.99 0.98 1.03 1.01 1.16 1.01 1.01 1.00 +599 STR string equal "" 1.75 1.46 1.83 1.52 1.46 1.42 1.37 1.00 +600 STR string equal long (!= len) 1.30 1.22 1.42 1.18 1.16 1.17 1.14 1.00 +601 STR string equal long (== len) 1.08 1.02 1.08 1.05 0.98 0.97 0.96 1.00 +602 STR string equal long (same obj) 1.39 1.20 1.39 1.23 1.16 1.14 1.09 1.00 +603 STR string equal mixed long 1.48 1.29 1.44 1.34 1.23 1.22 1.21 1.00 +604 STR string equal uni long 1.46 1.41 1.50 1.44 1.35 1.36 1.35 1.00 +605 STR/LIST length, obj shimmer 0.85 0.77 1.13 0.77 0.65 0.90 0.81 1.00 +606 SWITCH 1st true 1.62 1.38 1.77 1.42 1.38 1.30 1.27 1.00 +607 SWITCH 2nd true 1.67 1.41 1.85 1.46 1.38 1.31 1.28 1.00 +608 SWITCH 9th true 1.67 1.41 1.85 1.44 1.38 1.31 1.31 1.00 +609 SWITCH default true 1.64 1.33 1.82 1.41 1.33 1.23 1.21 1.00 +610 TRACE all set (rwu) 1.07 0.95 1.16 0.98 0.92 0.92 0.85 1.00 +611 TRACE no trace set 1.08 0.94 1.18 0.98 0.92 0.93 0.86 1.00 +612 TRACE read 1.07 0.95 1.17 0.96 0.93 0.93 0.87 1.00 +613 TRACE unset 1.07 0.95 1.16 0.98 0.92 0.92 0.86 1.00 +614 TRACE write 1.06 0.95 1.18 0.98 0.93 0.93 0.85 1.00 +615 UNSET catch var !exist 0.98 0.88 1.06 0.88 0.75 0.98 0.91 1.00 +616 UNSET catch var exists 1.36 1.14 1.57 1.19 1.10 1.05 1.00 1.00 +617 UNSET info check var !exist 1.84 1.50 2.12 1.62 1.44 1.38 1.28 1.00 +618 UNSET info check var exists 1.42 1.17 1.47 1.25 1.10 1.07 1.00 1.00 +619 UNSET nocomplain var !exist 1.34 1.07 1.49 1.10 1.00 0.98 0.93 1.00 +620 UNSET nocomplain var exists 1.38 1.16 1.54 1.22 1.11 1.05 1.00 1.00 +621 UNSET var exists 1.46 1.20 1.69 1.26 1.14 1.11 1.06 1.00 +622 UPLEVEL none 0.84 0.74 0.83 0.73 0.65 0.80 0.78 1.00 +623 UPLEVEL primed 1.06 0.93 1.14 0.94 0.84 0.94 0.86 1.00 +624 UPLEVEL to nseval 1.20 1.09 1.19 1.13 0.95 1.13 1.10 1.00 +625 UPLEVEL to proc 1.21 1.13 1.31 1.12 0.95 1.07 1.01 1.00 +626 VAR 'array set' of 100 elems 1.08 1.07 1.11 1.09 1.01 1.02 1.01 1.00 +627 VAR 100 'set's in array 1.10 1.05 1.09 1.08 1.03 1.05 1.03 1.00 +628 VAR access global 1.35 1.16 1.55 1.24 1.09 1.11 1.05 1.00 +629 VAR access local proc arg 1.70 1.38 1.84 1.43 1.38 1.27 1.24 1.00 +630 VAR access locally set 1.75 1.42 1.89 1.47 1.39 1.33 1.28 1.00 +631 VAR access upvar 1.45 1.12 1.62 1.21 1.12 1.09 1.09 1.00 +632 VAR incr global var 1000x 0.88 0.83 0.86 0.85 0.72 0.90 0.88 1.00 +633 VAR incr local var 1000x 0.86 0.84 0.86 0.83 0.71 0.88 0.85 1.00 +634 VAR incr upvar var 1000x 0.87 0.87 0.87 0.85 0.72 0.89 0.83 1.00 +635 VAR mset 1.36 1.18 1.47 1.24 1.05 1.13 1.11 1.00 +636 VAR mset (foreach) 1.23 1.09 1.32 1.09 0.86 0.98 0.95 1.00 +637 VAR ref absolute 0.98 0.93 1.05 0.99 0.79 0.95 0.94 1.00 +638 VAR ref local 1.24 1.15 1.38 1.17 1.19 1.14 1.12 1.00 +639 VAR ref variable 1.24 1.16 1.40 1.21 1.17 1.18 1.26 1.00 +640 VAR set array element 1.45 1.21 1.68 1.30 1.11 1.15 1.06 1.00 +641 VAR set scalar 1.82 1.46 2.11 1.50 1.43 1.32 1.29 1.00 +642 WORDCOUNT wc1 1.00 0.97 0.97 0.96 0.92 1.02 0.99 1.00 +643 WORDCOUNT wc2 0.98 0.91 1.10 0.91 0.84 0.99 0.95 1.00 +644 WORDCOUNT wc3 0.98 0.94 1.14 0.93 0.86 1.01 0.96 1.00 +644 BENCHMARKS 1:8.6b1.2 2:8.6b1.2 3:8.6b1.2 4:8.6b1.2 5:8.6b1.2 6:8.6b1.2 7:8.6b1.2 8:8.5.9 +FINISHED 2011-03-28 13:14:44 Index: tests/nre.test ================================================================== --- tests/nre.test +++ tests/nre.test @@ -26,12 +26,12 @@ if {[testConstraint testnrelevels]} { namespace eval testnre { namespace path ::tcl::mathop # - # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels, + # cmdFrame level, callFrame level and callback depth # variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] Index: tests/tailcall.test ================================================================== --- tests/tailcall.test +++ tests/tailcall.test @@ -25,12 +25,12 @@ # if {[testConstraint testnrelevels]} { namespace eval testnre { # - # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels, + # cmdFrame level, callFrame level and callback depth # variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] @@ -67,11 +67,11 @@ } } -body { a 0 } -cleanup { rename a {} -} -result {0 0 0 0 0 0} +} -result {0 0 0 0 0} test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup { set a { i { if {$i == 1} { depthDiff @@ -84,11 +84,11 @@ }} } -body { apply $a 0 } -cleanup { unset a -} -result {0 0 0 0 0 0} +} -result {0 0 0 0 0} test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup { proc a i { if {$i == 1} { depthDiff @@ -102,11 +102,11 @@ } -body { b 0 } -cleanup { rename a {} rename b {} -} -result {0 0 0 0 0 0} +} -result {0 0 0 0 0} test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup { namespace eval ::ns { namespace export * } @@ -125,11 +125,11 @@ } -body { b 0 } -cleanup { rename b {} namespace delete ::ns -} -result {0 0 0 0 0 0} +} -result {0 0 0 0 0} test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup { proc b i { if {$i == 1} { depthDiff @@ -143,11 +143,11 @@ } -body { a b 0 } -cleanup { rename a {} rename b {} -} -result {0 0 0 0 0 0} +} -result {0 0 0 0 0} test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup { # # This test fails because ns-unknown is not NR-enabled # @@ -168,11 +168,11 @@ a b 0 } -cleanup { rename a {} rename c {} rename d {} -} -result {0 0 0 0 0 0} +} -result {0 0 0 0 0} test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup { catch {rename foo {}} oo::class create foo { method b i { @@ -189,11 +189,11 @@ foo create a a b 0 } -cleanup { rename a {} rename foo {} -} -result {0 0 0 0 0 0} +} -result {0 0 0 0 0} test tailcall-1 {tailcall} -body { namespace eval a { variable x *::a proc xset {} { Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -288,11 +288,46 @@ tclThreadTest.o tclUnixTest.o XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o -GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ +#-------------------------------------------------------------------------- +# Choose the default allocator to link in. Override with the env-var +# TCL_ALLOCATOR if present. Note that all allocators will be compiled, +# changing them just requires relinking. +#-------------------------------------------------------------------------- + +PURIFY = tclAllocPurify.o +PURIFY_FLAGS = -DPURIFY% -DTCL_ALLOCATOR=PURIFY + +NATIVE = tclAllocNative.o +NATIVE_FLAGS = -DTCL_ALLOCATOR=NATIVE + +ZIPPY = tclAllocZippy.o +ZIPPY_FLAGS = -DUSE_THREAD_ALLOC% -DTCL_ALLOCATOR=ZIPPY + +ALLOCATOR_DEFAULT = $(NATIVE) +ALLOCATORS = $(PURIFY) $(NATIVE) $(ZIPPY) + +WHERE = $(CC_SWITCHES) $(CFLAGS) + +ifdef TCL_ALLOCATOR + ALLOCATOR = $($(TCL_ALLOCATOR)) +else ifneq (,$(filter $(PURIFY_FLAGS), $(WHERE))) + ALLOCATOR = $(PURIFY) +else ifneq (,$(filter $(NATIVE_FLAGS), $(WHERE))) + ALLOCATOR = $(NATIVE) +else ifneq (,$(filter $(ZIPPY_FLAGS), $(WHERE))) + ALLOCATOR = $(ZIPPY) +endif + +ifeq (,$(filter $(ALLOCATORS), $(ALLOCATOR))) + ALLOCATOR = $(ALLOCATOR_DEFAULT) +endif + +GENERIC_OBJS = $(ALLOCATOR) \ + regcomp.o regexec.o regfree.o regerror.o \ tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompCmdsSZ.o \ tclCompExpr.o tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ tclEncoding.o tclEnsemble.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ @@ -303,14 +338,14 @@ tclObj.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ - tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ + tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ tclTomMathInterface.o \ - tclAssembly.o + tclAssembly.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ @@ -382,11 +417,13 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/regcomp.c \ $(GENERIC_DIR)/regexec.c \ $(GENERIC_DIR)/regfree.c \ $(GENERIC_DIR)/regerror.c \ - $(GENERIC_DIR)/tclAlloc.c \ + $(GENERIC_DIR)/tclAllocNative.c \ + $(GENERIC_DIR)/tclAllocPurify.c \ + $(GENERIC_DIR)/tclAllocZippy.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ $(GENERIC_DIR)/tclCkalloc.c \ @@ -445,11 +482,10 @@ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ - $(GENERIC_DIR)/tclThreadAlloc.c \ $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ @@ -609,11 +645,11 @@ doc: # The following target is configured by autoconf to generate either a shared # library or non-shared library for Tcl. -${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE} +${LIB_FILE}: $(ALLOCATORS) ${OBJS} ${STUB_LIB_FILE} rm -f $@ @MAKE_LIB@ @if test "x$(DLL_INSTALL_DIR)" = "x$(BIN_INSTALL_DIR)"; then\ cp ${ZLIB_DIR}/win32/zlib1.dll .;\ fi @@ -1047,12 +1083,18 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regerror.c tclAppInit.o: $(UNIX_DIR)/tclAppInit.c $(CC) -c $(APP_CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c -tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c +tclAllocNative.o: $(GENERIC_DIR)/tclAllocNative.c $(GENERIC_DIR)/tclAllocZippy.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAllocNative.c + +tclAllocPurify.o: $(GENERIC_DIR)/tclAllocPurify.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAllocPurify.c + +tclAllocZippy.o: $(GENERIC_DIR)/tclAllocZippy.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAllocZippy.c tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c tclAsync.o: $(GENERIC_DIR)/tclAsync.c @@ -1323,13 +1365,10 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c tclThread.o: $(GENERIC_DIR)/tclThread.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThread.c -tclThreadAlloc.o: $(GENERIC_DIR)/tclThreadAlloc.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadAlloc.c - tclThreadJoin.o: $(GENERIC_DIR)/tclThreadJoin.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadJoin.c tclThreadStorage.o: $(GENERIC_DIR)/tclThreadStorage.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c Index: unix/tclUnixPipe.c ================================================================== --- unix/tclUnixPipe.c +++ unix/tclUnixPipe.c @@ -428,12 +428,12 @@ /* * We need to allocate and convert this before the fork so it is properly * deallocated later */ - dsArray = TclStackAlloc(interp, argc * sizeof(Tcl_DString)); - newArgv = TclStackAlloc(interp, (argc+1) * sizeof(char *)); + dsArray = ckalloc(argc * sizeof(Tcl_DString)); + newArgv = ckalloc((argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); } @@ -501,12 +501,12 @@ */ for (i = 0; i < argc; i++) { Tcl_DStringFree(&dsArray[i]); } - TclStackFree(interp, newArgv); - TclStackFree(interp, dsArray); + ckfree(newArgv); + ckfree(dsArray); if (pid == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't fork child process: %s", Tcl_PosixError(interp))); goto error; Index: unix/tclUnixThrd.c ================================================================== --- unix/tclUnixThrd.c +++ unix/tclUnixThrd.c @@ -672,16 +672,15 @@ #else return inet_ntoa(addr); #endif } -#ifdef TCL_THREADS +#if defined(TCL_THREADS) /* * Additions by AOL for specialized thread memory allocator. */ -#ifdef USE_THREAD_ALLOC static volatile int initialized = 0; static pthread_key_t key; typedef struct allocMutex { Tcl_Mutex tlock; @@ -713,10 +712,11 @@ return; } pthread_mutex_destroy(&lockPtr->plock); free(lockPtr); } + void TclpFreeAllocCache( void *ptr) { @@ -756,12 +756,13 @@ TclpSetAllocCache( void *arg) { pthread_setspecific(key, arg); } -#endif /* USE_THREAD_ALLOC */ +#endif +#ifdef TCL_THREADS void * TclpThreadCreateKey(void) { pthread_key_t *ptkeyPtr;