From faf9def2a7c70743d49dd1e923d82b8dc0f9d718 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 12:54:54 +0000 Subject: development branch for allocator changes --- README.mig-alloc-reform | 65 ++ generic/tclAlloc.c | 1484 +++++++++++++++++++++++++++++++-------------- generic/tclAssembly.c | 15 +- generic/tclBasic.c | 50 +- generic/tclCkalloc.c | 4 - generic/tclCmdAH.c | 18 +- generic/tclCmdIL.c | 21 +- generic/tclCmdMZ.c | 22 +- generic/tclCompCmds.c | 26 +- generic/tclCompCmdsSZ.c | 58 +- generic/tclCompExpr.c | 49 +- generic/tclCompile.c | 8 +- generic/tclDictObj.c | 10 +- generic/tclEvent.c | 6 +- generic/tclExecute.c | 642 ++++---------------- generic/tclFCmd.c | 4 +- generic/tclFileName.c | 4 +- generic/tclIOCmd.c | 4 +- generic/tclIndexObj.c | 8 +- generic/tclInt.decls | 18 +- generic/tclInt.h | 310 +++------- generic/tclIntDecls.h | 24 +- generic/tclInterp.c | 8 +- generic/tclNamesp.c | 17 +- generic/tclOOCall.c | 4 +- generic/tclOODefineCmds.c | 10 +- generic/tclOOMethod.c | 14 +- generic/tclObj.c | 71 +-- generic/tclParse.c | 20 +- generic/tclProc.c | 27 +- generic/tclScan.c | 9 +- generic/tclStubInit.c | 6 +- generic/tclTest.c | 8 +- generic/tclThreadAlloc.c | 1081 --------------------------------- generic/tclTrace.c | 8 +- tests/nre.test | 4 +- tests/tailcall.test | 18 +- unix/Makefile.in | 11 +- unix/tclUnixPipe.c | 8 +- unix/tclUnixThrd.c | 7 +- 40 files changed, 1519 insertions(+), 2662 deletions(-) create mode 100644 README.mig-alloc-reform delete mode 100755 generic/tclThreadAlloc.c diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform new file mode 100644 index 0000000..139af2e --- /dev/null +++ b/README.mig-alloc-reform @@ -0,0 +1,65 @@ +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 improvement in zippy's memory usage: try to split blocks in + the shared cache before allocating new ones from the system + + 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 ** + * 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 + + +** 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 diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 6fff92b..782a12b 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -1,253 +1,428 @@ /* * tclAlloc.c -- * - * This is a very fast storage allocator. It allocates blocks of a small - * number of different sizes, and keeps free lists of each size. Blocks - * that don't exactly fit are passed up to the next larger size. Blocks - * over a certain size are directly allocated from the system. + * This is a very flexible storage allocator for Tcl, for use with or + * without threads. Depending on the compile flags, it builds as: * - * Copyright (c) 1983 Regents of the University of California. - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * (1) Build flags: TCL_ALLOC_NATIVE + * NATIVE: use the native malloc and a per-thread Tcl_Obj pool, with + * inter-thread recycling of objects. The per-thread pool can be + * disabled at startup with an env var, thus providing the PURIFY + * behaviour that is useful for valgrind and similar tools. Note that + * the PURIFY costs are negligible when disabled, but when enabled + * Tcl_Obj allocs will be even slower than in a full PURIFY build + * NOTE: the obj pool shares all code with zippy's smallest allocs! + * It does look overcomplicated for this particular case, but + * keeping them together allows simpler maintenance and avoids + * the need for separate debugging + * TODO: in this case build ZIPPY as a preloadable malloc-replacement * - * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. + * (2) Build flags: TCL_ALLOC_ZIPPY + * ZIPPY: use the ex-tclThreadAlloc, essentially aolserver's + * fast threaded allocator. Mods with respect to the original: + * - change in the block sizes, so that the smallest alloc is + * Tcl_Obj-sized + * - share the Tcl_Obj pool with the smallest allocs pool for + * improved cache usage + * - split blocks in the shared pool before mallocing again for + * improved cache usage + * - ?change in the number of blocks to move to/from the shared + * cache: it used to be a fixed number, it is now computed + * to leave a fixed number in the thread's pool. This improves + * sharing behaviour when one thread uses a lot of memory once + * and rarely again (eg, at startup), at the cost of slowing + * slightly threads that allocate/free large numbers of blocks + * repeatedly + * - stats and Tcl_GetMemoryInfo disabled per default, enable with + * -DZIPPY_STATS + * - adapt for unthreaded usage as replacement of the ex tclAlloc + * - -DHAVE_FAST_TSD: use fast TSD via __thread where available + * - (TODO!) build zippy as a pre-loadable library to use with a + * native build as a malloc replacement. Difficulties are: + * (a) make that portable (easy enough on modern elf/unix, to + * be researched on win and mac) + * (b) coordinate the Tcl_Obj pool and the smallest allocs, + * as they are now addressed from different files. This + * might require a special Tcl build with no + * TclSmallAlloc, and a separate preloadable for use with + * native builds? Or else separate them again, but that's + * not really good I think. + * + * NOTES: + * . this would be the best option, instead of MULTI. It + * could be built in two versions (perf, debug/stats) + * . would a preloaded zippy be slower than builtin? + * Possibly, due to extra indirection. + * + * (3) Build flags: TCL_ALLOC_MULTI + * MULTI: all of the above, selectable at startup with an env + * var. This build will be very slightly slower than the specific + * builds above, but is completely portable: it does not depend on + * any help from the loader or such. + * + * All variants can be built for both threaded and unthreaded Tcl. + * + * The Initial Developer of the Original Code is America Online, Inc. + * Portions created by AOL are Copyright (C) 1999 America Online, Inc. + * + * 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. */ -/* - * 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 +/* + * This macro is used to properly align the memory allocated by Tcl, giving + * the same alignment as the native malloc. + */ -#ifdef TCL_DEBUG -# define DEBUG -/* #define MSTATS */ -# define RCHECK +#if defined(__APPLE__) +#define TCL_ALLOCALIGN 16 +#else +#define TCL_ALLOCALIGN (2*sizeof(void *)) #endif +#undef TclpAlloc +#undef TclpRealloc +#undef TclpFree +#undef TclSmallAlloc +#undef TclSmallFree + +#if (TCL_ALLOCATOR == aNATIVE) || (TCL_ALLOCATOR == aPURIFY) /* - * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait - * until Tcl uses config.h properly. + * Not much of this file is needed, most things are dealt with in the + * macros. Just shunt the allocators for use by the library, the core + * never calls this. + * + * This is all that is needed for a TCL_ALLOC_PURIFY build, a native build + * needs the Tcl_Obj pools too. */ + +char * +TclpAlloc( + unsigned int reqSize) +{ + return malloc(reqSize); +} -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) -typedef unsigned long caddr_t; -#endif +char * +TclpRealloc( + char *ptr, + unsigned int reqSize) +{ + return realloc(ptr, reqSize); +} + +void +TclpFree( + char *ptr) +{ + free(ptr); +} + +#endif /* end of common code for PURIFY and NATIVE*/ + +#if TCL_ALLOCATOR != aPURIFY +/* + * The rest of this file deals with ZIPPY and MULTI builds, as well as the + * Tcl_Obj pools for NATIVE + */ /* - * 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. + * Note: we rely on the optimizer to remove unneeded code, instead of setting + * up a maze of #ifdefs all over the code. + * We should insure that debug builds do at least this much optimization, right? */ -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 */ -#ifdef RCHECK - 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 */ - -#ifdef RCHECK -#define RSLOP sizeof(unsigned short) +#if TCL_ALLOCATOR == aZIPPY +# define allocator aZIPPY +# define ALLOCATOR_BASE aZIPPY +#elif TCL_ALLOCATOR == aNATIVE +/* Keep the option to switch PURIFY mode on! */ +static int allocator = aNONE; +# define ALLOCATOR_BASE aNATIVE +# define RCHECK 0 +# undef ZIPPY_STATS #else -#define RSLOP 0 +/* MULTI */ + static int allocator = aNONE; +# define ALLOCATOR_BASE aZIPPY +#endif + +#if TCL_ALLOCATOR != aZIPPY +static void ChooseAllocator(); #endif -#define OVERHEAD (sizeof(union overhead) + RSLOP) /* - * Macro to make it easier to refer to the end-of-block guard magic. + * If range checking is enabled, an additional byte will be allocated to store + * the magic number at the end of the requested memory. */ -#define BLOCK_END(overPtr) \ - (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize)) +#ifndef RCHECK +# ifdef NDEBUG +# define RCHECK 0 +# else +# define RCHECK 1 +# endif +#endif /* - * 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. + * The following struct 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. */ -#define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) -#define NBUCKETS (13 - (MINBLOCK >> 4)) -#define MAXMALLOC (1<<(NBUCKETS+2)) -static union overhead *nextf[NBUCKETS]; +typedef struct Block { + union { + struct 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. */ +} Block; + +#define ALIGN(x) (((x) + TCL_ALLOCALIGN - 1) & ~(TCL_ALLOCALIGN - 1)) +#define OFFSET ALIGN(sizeof(Block)) + +#define nextBlock u.next +#define sourceBucket u.s.bucket +#define magicNum1 u.s.magic1 +#define magicNum2 u.s.magic2 +#define MAGIC 0xEF +#define blockReqSize reqSize /* - * 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. + * The following defines the minimum and maximum block sizes and the number + * of buckets in the bucket cache. + * 32b 64b Apple-32b + * TCL_ALLOCALIGN 8 16 16 + * sizeof(Block) 8 16 16 + * OFFSET 8 16 16 + * sizeof(Tcl_Obj) 24 48 24 + * ALLOCBASE 24 48 24 + * MINALLOC 24 48 24 + * NBUCKETS 11 10 11 + * MAXALLOC 24576 24576 24576 + * small allocs 1024 512 1024 + * at a time */ -struct block { - struct block *nextPtr; /* Linked list. */ - struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte - * alignment for suballocated blocks. */ -}; +#if TCL_ALLOCATOR == aNATIVE +#define MINALLOC MAX(OFFSET, sizeof(Tcl_Obj)) +#else +#define MINALLOC ALIGN(MAX(OFFSET+8, sizeof(Tcl_Obj))) +#endif -static struct block *blockList; /* Tracks the suballocated blocks. */ -static struct block bigBlocks={ /* Big blocks aren't suballocated. */ - &bigBlocks, &bigBlocks -}; +#define NBUCKETS 10 /* previously (11 - (MINALLOC >> 5)) */ +#define MAXALLOC (MINALLOC << (NBUCKETS - 1)) + +#if TCL_ALLOCATOR == aNATIVE +# define NBUCKETS_0 1 +# define nBuckets 1 +#else +# define NBUCKETS_0 NBUCKETS +# if TCL_ALLOCATOR == aZIPPY +# define nBuckets NBUCKETS +# else + static int nBuckets = NBUCKETS; +# endif +#endif /* - * The allocator is protected by a special mutex that must be explicitly - * initialized. Futhermore, because Tcl_Alloc may be used before anything else - * in Tcl, we make this module self-initializing after all with the allocInit - * variable. + * The following structure defines a bucket of blocks, optionally with various + * accounting and statistics information. */ -#ifdef TCL_THREADS -static Tcl_Mutex *allocMutexPtr; +typedef struct Bucket { + Block *firstPtr; /* First block available */ + long numFree; /* Number of blocks available */ +#ifdef ZIPPY_STATS + /* 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 */ #endif -static int allocInit = 0; - -#ifdef MSTATS +} Bucket; /* - * numMallocs[i] is the difference between the number of mallocs and frees for - * a given block size. + * The following structure defines a cache of buckets, at most one per + * thread. */ -static unsigned int numMallocs[NBUCKETS+1]; +typedef struct Cache { +#if defined(TCL_THREADS) + struct Cache *nextPtr; /* Linked list of cache entries */ +#ifdef ZIPPY_STATS + Tcl_ThreadId owner; /* Which thread's cache is this? */ #endif - -#if defined(DEBUG) || defined(RCHECK) -#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 +#ifdef ZIPPY_STATS + int totalAssigned; /* Total space assigned to thread */ +#endif + Bucket buckets[1]; /* The buckets for this thread */ +} Cache; + /* - * Prototypes for functions used only in this file. + * The following array specifies various per-bucket limits and locks. The + * values are statically initialized to avoid calculating them repeatedly. */ -static void MoreCore(int bucket); - +static struct { + size_t blockSize; /* Bucket blocksize. */ +#if defined(TCL_THREADS) + int maxBlocks; /* Max blocks before move to share. */ + int numMove; /* Num blocks to move to share. */ + Tcl_Mutex *lockPtr; /* Share bucket lock. */ +#endif +} bucketInfo[NBUCKETS_0]; + /* - *------------------------------------------------------------------------- - * - * TclInitAlloc -- - * - * Initialize the memory system. - * - * Results: - * None. - * - * Side effects: - * Initialize the mutex used to serialize allocations. - * - *------------------------------------------------------------------------- + * Static functions defined in this file. */ -void -TclInitAlloc(void) -{ - if (!allocInit) { - allocInit = 1; -#ifdef TCL_THREADS - allocMutexPtr = Tcl_GetAllocMutex(); +static Cache * GetCache(void); +static int GetBlocks(Cache *cachePtr, int bucket); +static inline Block * Ptr2Block(char *ptr); +static inline char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); + +#if defined(TCL_THREADS) + +static Cache *firstCachePtr = NULL; +static Cache *sharedPtr = NULL; + +static Tcl_Mutex *listLockPtr; +static Tcl_Mutex *objLockPtr; + +static void LockBucket(Cache *cachePtr, int bucket); +static void UnlockBucket(Cache *cachePtr, int bucket); +static void PutBlocks(Cache *cachePtr, int bucket, int numMove); + +#if defined(HAVE_FAST_TSD) +static __thread Cache *tcachePtr; +static __thread int allocInitialized = 0; + +# define GETCACHE(cachePtr) \ + do { \ + if (!allocInitialized) { \ + allocInitialized = 1; \ + tcachePtr = GetCache(); \ + } \ + (cachePtr) = tcachePtr; \ + } while (0) +#else +# define GETCACHE(cachePtr) \ + do { \ + (cachePtr) = TclpGetAllocCache(); \ + if ((cachePtr) == NULL) { \ + (cachePtr) = GetCache(); \ + } \ + } while (0) #endif +#else /* NOT THREADS! */ + +static int allocInitialized = 0; + +#define TclpSetAllocCache() +#define PutBlocks(cachePtr, bucket, numMove) +#define firstCachePtr sharedCachePtr + +# define GETCACHE(cachePtr) \ + do { \ + if (!allocInitialized) { \ + allocInitialized = 1; \ + GetCache(); \ + } \ + (cachePtr) = sharedPtr; \ + } while (0) + +static void * +TclpGetAllocCache(void) +{ + if (!allocInitialized) { + allocInitialized = 1; + GetCache(); } + return sharedPtr; } +#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(). + * Block2Ptr, Ptr2Block -- * - * After this function is called, all memory allocated with TclpAlloc() - * should be considered unusable. + * Convert between internal blocks and user pointers. * * Results: - * None. + * User pointer or internal block. * * 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. + * Invalid blocks will abort the server. * - *------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -void -TclFinalizeAllocSubsystem(void) +static inline char * +Block2Ptr( + Block *blockPtr, + int bucket, + unsigned int reqSize) { - unsigned int i; - struct block *blockPtr, *nextPtr; + register void *ptr; + + blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC; + blockPtr->sourceBucket = bucket; + blockPtr->blockReqSize = reqSize; + ptr = (void *) (((char *)blockPtr) + OFFSET); +#if RCHECK + ((unsigned char *)(ptr))[reqSize] = MAGIC; +#endif + return (char *) ptr; +} - Tcl_MutexLock(allocMutexPtr); - for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) { - nextPtr = blockPtr->nextPtr; - TclpSysFree(blockPtr); - } - blockList = NULL; +static inline Block * +Ptr2Block( + char *ptr) +{ + register Block *blockPtr; - for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) { - nextPtr = blockPtr->nextPtr; - TclpSysFree(blockPtr); - blockPtr = nextPtr; + blockPtr = (Block *) (((char *) ptr) - OFFSET); + if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) { + Tcl_Panic("alloc: invalid block: %p: %x %x", + blockPtr, blockPtr->magicNum1, blockPtr->magicNum2); } - bigBlocks.nextPtr = &bigBlocks; - bigBlocks.prevPtr = &bigBlocks; - - for (i=0 ; iblockReqSize] != MAGIC) { + Tcl_Panic("alloc: invalid block: %p: %x %x %x", + blockPtr, blockPtr->magicNum1, blockPtr->magicNum2, + ((unsigned char *) ptr)[blockPtr->blockReqSize]); } -#ifdef MSTATS - numMallocs[i] = 0; #endif - Tcl_MutexUnlock(allocMutexPtr); + return blockPtr; } /* *---------------------------------------------------------------------- * - * TclpAlloc -- + * GetCache --- * - * Allocate more memory. + * Gets per-thread memory cache, allocating it if necessary. * * Results: - * None. + * Pointer to cache. * * Side effects: * None. @@ -255,183 +430,237 @@ TclFinalizeAllocSubsystem(void) *---------------------------------------------------------------------- */ -char * -TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ +static Cache * +GetCache(void) { - register union overhead *overPtr; - register long bucket; - register unsigned amount; - struct block *bigBlockPtr = NULL; - - if (!allocInit) { - /* - * We have to make the "self initializing" because Tcl_Alloc may be - * used before any other part of Tcl. E.g., see main() for tclsh! + Cache *cachePtr; + unsigned int i; +#if TCL_ALLOCATOR == aZIPPY +#define allocSize (sizeof(Cache) + (NBUCKETS -1)*sizeof(Bucket)) +#elif TCL_ALLOCATOR == aNATIVE +#define allocSize sizeof(Cache) +#else + unsigned int allocSize; +#endif + + /* + * Set the params for the correct allocator + */ + +#if TCL_ALLOCATOR != aZIPPY + if (allocator == aNONE) { + /* This insures that it is set just once, as any changes after + * initialization guarantee a hard crash */ + + ChooseAllocator(); + } - TclInitAlloc(); +#if TCL_ALLOCATOR == aMULTI + if (allocator == aZIPPY) { + allocSize = (sizeof(Cache) + (NBUCKETS -1)*sizeof(Bucket)); + nBuckets = NBUCKETS; + } else { + allocSize = sizeof(Cache); + nBuckets = 1; } - Tcl_MutexLock(allocMutexPtr); +#endif +#endif /* - * First the simple case: we simple allocate big blocks directly. + * Check for first-time initialization. */ - if (numBytes >= MAXMALLOC - OVERHEAD) { - if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + OVERHEAD + numBytes), 0); - } - if (bigBlockPtr == NULL) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - bigBlockPtr->nextPtr = bigBlocks.nextPtr; - bigBlocks.nextPtr = bigBlockPtr; - bigBlockPtr->prevPtr = &bigBlocks; - bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; - - overPtr = (union overhead *) (bigBlockPtr + 1); - overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = 0xff; -#ifdef MSTATS - numMallocs[NBUCKETS]++; +#if defined(TCL_THREADS) + if (listLockPtr == NULL) { + Tcl_Mutex *initLockPtr; + initLockPtr = Tcl_GetAllocMutex(); + Tcl_MutexLock(initLockPtr); + if (listLockPtr == NULL) { + listLockPtr = TclpNewAllocMutex(); + objLockPtr = TclpNewAllocMutex(); #endif - -#ifdef RCHECK - /* - * 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; + for (i = 0; i < nBuckets; ++i) { + bucketInfo[i].blockSize = MINALLOC << i; +#if defined(TCL_THREADS) + /* TODO: clearer logic? Change move to keep? */ + bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].numMove = i < NBUCKETS - 1 ? + 1 << (NBUCKETS - 2 - i) : 1; + bucketInfo[i].lockPtr = TclpNewAllocMutex(); #endif - - Tcl_MutexUnlock(allocMutexPtr); - return (void *)(overPtr+1); + } +#if defined(TCL_THREADS) + sharedPtr = calloc(1, allocSize); + firstCachePtr = sharedPtr; + } + Tcl_MutexUnlock(initLockPtr); } +#endif + if (allocator == aPURIFY) { + bucketInfo[0].maxBlocks = 0; + } + /* - * Convert amount of memory requested into closest block size stored in - * hash buckets which satisfies request. Account for space used per block - * for accounting. + * Get this thread's cache, allocating if necessary. */ - amount = MINBLOCK; /* size of first bucket */ - bucket = MINBLOCK >> 4; - - while (numBytes + OVERHEAD > amount) { - amount <<= 1; - if (amount == 0) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = calloc(1, allocSize); + if (cachePtr == NULL) { + Tcl_Panic("alloc: could not allocate new cache"); } - bucket++; +#if defined(TCL_THREADS) + Tcl_MutexLock(listLockPtr); + cachePtr->nextPtr = firstCachePtr; + firstCachePtr = cachePtr; + Tcl_MutexUnlock(listLockPtr); +#ifdef ZIPPY_STATS + cachePtr->owner = Tcl_GetCurrentThread(); +#endif + TclpSetAllocCache(cachePtr); +#endif } - ASSERT(bucket < NBUCKETS); + return cachePtr; +} + +#if defined(TCL_THREADS) +/* + *---------------------------------------------------------------------- + * + * 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; /* - * If nothing in hash bucket right now, request more memory from the - * system. + * Flush blocks. */ - if ((overPtr = nextf[bucket]) == NULL) { - MoreCore(bucket); - if ((overPtr = nextf[bucket]) == NULL) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; + for (bucket = 0; bucket < nBuckets; ++bucket) { + if (cachePtr->buckets[bucket].numFree > 0) { + PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].numFree); } } /* - * Remove from linked list + * Remove from pool list. */ - nextf[bucket] = overPtr->next; - overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = (unsigned char) bucket; - -#ifdef MSTATS - numMallocs[bucket]++; -#endif - -#ifdef RCHECK - /* - * 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)); + Tcl_MutexLock(listLockPtr); + nextPtrPtr = &firstCachePtr; + while (*nextPtrPtr != cachePtr) { + nextPtrPtr = &(*nextPtrPtr)->nextPtr; + } + *nextPtrPtr = cachePtr->nextPtr; + cachePtr->nextPtr = NULL; + Tcl_MutexUnlock(listLockPtr); + free(cachePtr); } +#endif +#if TCL_ALLOCATOR != aNATIVE /* *---------------------------------------------------------------------- * - * MoreCore -- - * - * Allocate more memory to the indicated bucket. + * TclpAlloc -- * - * Assumes Mutex is already held. + * Allocate memory. * * Results: - * None. + * Pointer to memory just beyond Block pointer. * * Side effects: - * Attempts to get more memory from the system. + * May allocate more blocks for a bucket. * *---------------------------------------------------------------------- */ -static void -MoreCore( - int bucket) /* What bucket to allocat to. */ +char * +TclpAlloc( + unsigned int reqSize) { - 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. - */ + Cache *cachePtr; + Block *blockPtr; + register int bucket; + size_t size; - size = 1 << (bucket + 3); - ASSERT(size > 0); + if (allocator < aNONE) { + return (void *) malloc(reqSize); + } + + GETCACHE(cachePtr); - amount = MAXMALLOC; - numBlocks = amount / size; - ASSERT(numBlocks*size == amount); +#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; - blockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + amount), 1); - /* no more room! */ - if (blockPtr == NULL) { - return; + if (((size_t) reqSize) > max - OFFSET - RCHECK) { + /* Requested allocation exceeds memory */ + return NULL; + } } - blockPtr->nextPtr = blockList; - blockList = blockPtr; - - overPtr = (union overhead *) (blockPtr + 1); +#endif /* - * Add new memory allocated to that on free list for this hash bucket. + * 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. */ - nextf[bucket] = overPtr; - while (--numBlocks > 0) { - overPtr->next = (union overhead *)((caddr_t)overPtr + size); - overPtr = (union overhead *)((caddr_t)overPtr + size); + blockPtr = NULL; + size = reqSize + OFFSET; +#if RCHECK + size++; +#endif + if (size > MAXALLOC) { + bucket = nBuckets; + blockPtr = malloc(size); +#ifdef ZIPPY_STATS + if (blockPtr != NULL) { + cachePtr->totalAssigned += reqSize; + } +#endif + } 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--; +#ifdef ZIPPY_STATS + cachePtr->buckets[bucket].numRemoves++; + cachePtr->buckets[bucket].totalAssigned += reqSize; +#endif + } + } + if (blockPtr == NULL) { + return NULL; } - overPtr->next = NULL; + return Block2Ptr(blockPtr, bucket, reqSize); } /* @@ -439,64 +668,66 @@ MoreCore( * * TclpFree -- * - * Free memory. + * Return blocks to the thread block cache. * * Results: * None. * * Side effects: - * None. + * May move blocks to shared cache. * *---------------------------------------------------------------------- */ void TclpFree( - char *oldPtr) /* Pointer to memory to free. */ + char *ptr) { - register long size; - register union overhead *overPtr; - struct block *bigBlockPtr; + Cache *cachePtr; + Block *blockPtr; + int bucket; - if (oldPtr == NULL) { - return; + if (allocator < aNONE) { + return free((char *) ptr); } - Tcl_MutexLock(allocMutexPtr); - overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead)); + GETCACHE(cachePtr); - ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */ - ASSERT(overPtr->overMagic1 == MAGIC); - if (overPtr->overMagic0 != MAGIC || overPtr->overMagic1 != MAGIC) { - Tcl_MutexUnlock(allocMutexPtr); + if (ptr == NULL) { 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); + /* + * 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. + */ - Tcl_MutexUnlock(allocMutexPtr); + blockPtr = Ptr2Block(ptr); + bucket = blockPtr->sourceBucket; + if (bucket == nBuckets) { +#ifdef ZIPPY_STATS + cachePtr->totalAssigned -= blockPtr->blockReqSize; +#endif + free(blockPtr); return; } - ASSERT(size < NBUCKETS); - overPtr->next = nextf[size]; /* also clobbers overMagic */ - nextf[size] = overPtr; -#ifdef MSTATS - numMallocs[size]--; +#ifdef ZIPPY_STATS + cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; +#endif + blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr; + cachePtr->buckets[bucket].numFree++; +#ifdef ZIPPY_STATS + cachePtr->buckets[bucket].numInserts++; +#endif +#if defined(TCL_THREADS) + if (cachePtr != sharedPtr && + cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { + PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); + } #endif - - Tcl_MutexUnlock(allocMutexPtr); } /* @@ -504,138 +735,308 @@ TclpFree( * * TclpRealloc -- * - * Reallocate memory. + * Re-allocate memory to a larger or smaller size. * * Results: - * None. + * Pointer to memory just beyond Block pointer. * * Side effects: - * None. + * Previous memory, if any, may be freed. * *---------------------------------------------------------------------- */ char * -TclpRealloc( - char *oldPtr, /* Pointer to alloced block. */ - unsigned int numBytes) /* New size of memory. */ +TclpRealloc( + char *ptr, + unsigned int reqSize) { - int i; - union overhead *overPtr; - struct block *bigBlockPtr; - int expensive; - unsigned long maxSize; - - if (oldPtr == NULL) { - return TclpAlloc(numBytes); + Cache *cachePtr; + Block *blockPtr; + void *newPtr; + size_t size, min; + int bucket; + + if (allocator < aNONE) { + return (void *) realloc((char *) ptr, reqSize); } - Tcl_MutexLock(allocMutexPtr); - - overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead)); + GETCACHE(cachePtr); - 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; + if (ptr == NULL) { + return TclpAlloc(reqSize); } - RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); - RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); - i = overPtr->bucketIndex; +#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 - OFFSET - RCHECK) { + /* Requested allocation exceeds memory */ + return NULL; + } + } +#endif /* - * If the block isn't in a bin, just realloc it. + * 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. */ - 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); + blockPtr = Ptr2Block(ptr); + size = reqSize + OFFSET; +#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) { +#ifdef ZIPPY_STATS + cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; + cachePtr->buckets[bucket].totalAssigned += reqSize; +#endif + return Block2Ptr(blockPtr, bucket, reqSize); + } + } else if (size > MAXALLOC) { +#ifdef ZIPPY_STATS + cachePtr->totalAssigned -= blockPtr->blockReqSize; + cachePtr->totalAssigned += reqSize; +#endif + blockPtr = realloc(blockPtr, size); + if (blockPtr == NULL) { return NULL; } + return Block2Ptr(blockPtr, nBuckets, reqSize); + } - if (prevPtr->nextPtr != bigBlockPtr) { - /* - * If the block has moved, splice the new block into the list - * where the old block used to be. - */ + /* + * Finally, perform an expensive malloc/copy/free. + */ - prevPtr->nextPtr = bigBlockPtr; - nextPtr->prevPtr = bigBlockPtr; + newPtr = TclpAlloc(reqSize); + if (newPtr != NULL) { + if (reqSize > blockPtr->blockReqSize) { + reqSize = blockPtr->blockReqSize; } + memcpy(newPtr, ptr, reqSize); + TclpFree(ptr); + } + return newPtr; +} +#ifdef ZIPPY_STATS + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMemoryInfo -- + * + * Return a list-of-lists of memory stats. + * + * Results: + * None. + * + * Side effects: + * List appended to given dstring. + * + *---------------------------------------------------------------------- + */ - overPtr = (union overhead *) (bigBlockPtr + 1); - -#ifdef MSTATS - numMallocs[NBUCKETS]++; +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 defined(TCL_THREADS) + if (cachePtr == sharedPtr) { + Tcl_DStringAppendElement(dsPtr, "shared"); + } else { + sprintf(buf, "thread%p", cachePtr->owner); + Tcl_DStringAppendElement(dsPtr, buf); + } +#else + Tcl_DStringAppendElement(dsPtr, "unthreaded"); #endif - -#ifdef RCHECK - /* - * Record allocated size of block and update magic number bounds. - */ - - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - BLOCK_END(overPtr) = RMAGIC; + 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); +#if defined(TCL_THREADS) + cachePtr = cachePtr->nextPtr; +#else + cachePtr = NULL; #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; + Tcl_MutexUnlock(listLockPtr); +} +#endif /* ZIPPY_STATS */ +#endif /* code above only for NATIVE allocator */ + +/* + *---------------------------------------------------------------------- + * + * 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) +{ + Cache *cachePtr; + Block *blockPtr; + Bucket *bucketPtr; + + GETCACHE(cachePtr); + bucketPtr = &cachePtr->buckets[0]; + + blockPtr = bucketPtr->firstPtr; + if (bucketPtr->numFree || GetBlocks(cachePtr, 0)) { + blockPtr = bucketPtr->firstPtr; + bucketPtr->firstPtr = blockPtr->nextBlock; + bucketPtr->numFree--; +#ifdef ZIPPY_STATS + bucketPtr->numRemoves++; + bucketPtr->totalAssigned += sizeof(Tcl_Obj); +#endif } + return blockPtr; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ - if (expensive) { - void *newPtr; +void +TclSmallFree( + void *ptr) +{ + Cache *cachePtr; + Block *blockPtr = ptr; + Bucket *bucketPtr; - Tcl_MutexUnlock(allocMutexPtr); + GETCACHE(cachePtr); + bucketPtr = &cachePtr->buckets[0]; - newPtr = TclpAlloc(numBytes); - if (newPtr == NULL) { - return NULL; - } - maxSize -= OVERHEAD; - if (maxSize < numBytes) { - numBytes = maxSize; +#ifdef ZIPPY_STATS + bucketPtr->totalAssigned -= sizeof(Tcl_Obj); +#endif + blockPtr->nextBlock = bucketPtr->firstPtr; + bucketPtr->firstPtr = blockPtr; + bucketPtr->numFree++; +#ifdef ZIPPY_STATS + bucketPtr->numInserts++; +#endif + + if (bucketPtr->numFree > bucketInfo[0].maxBlocks) { + if (allocator == aPURIFY) { + /* undo */ + bucketPtr->numFree = 0; + bucketPtr->firstPtr = NULL; + free((char *) blockPtr); + return; } - memcpy(newPtr, oldPtr, (size_t) numBytes); - TclpFree(oldPtr); - return newPtr; +#if defined(TCL_THREADS) + PutBlocks(cachePtr, 0, bucketInfo[0].numMove); +#endif } +} + +#if defined(TCL_THREADS) +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ - /* - * Ok, we don't have to copy, it fits as-is - */ - -#ifdef RCHECK - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - BLOCK_END(overPtr) = RMAGIC; +static void +LockBucket( + Cache *cachePtr, + int bucket) +{ +#if 0 + if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) { + Tcl_MutexLock(bucketInfo[bucket].lockPtr); + cachePtr->buckets[bucket].numWaits++; + sharedPtr->buckets[bucket].numWaits++; + } +#else + Tcl_MutexLock(bucketInfo[bucket].lockPtr); #endif +#ifdef ZIPPY_STATS + cachePtr->buckets[bucket].numLocks++; + sharedPtr->buckets[bucket].numLocks++; +#endif +} - Tcl_MutexUnlock(allocMutexPtr); - return(oldPtr); +static void +UnlockBucket( + Cache *cachePtr, + int bucket) +{ + Tcl_MutexUnlock(bucketInfo[bucket].lockPtr); } /* *---------------------------------------------------------------------- * - * mstats -- + * PutBlocks -- * - * 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. + * Return unused blocks to the shared cache. * * Results: * None. @@ -646,95 +1047,203 @@ TclpRealloc( *---------------------------------------------------------------------- */ -#ifdef MSTATS -void -mstats( - char *s) /* Where to write info. */ +static void +PutBlocks( + Cache *cachePtr, + int bucket, + int numMove) { - register int i, j; - register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; + register Block *lastPtr, *firstPtr; + register int n = numMove; - 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)); - } + /* + * Before acquiring the lock, walk the block list to find the last block + * to be moved. + */ - fprintf(stderr, "\nused:\t"); - for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); - totalUsed += numMallocs[i] * (1 << (i + 3)); + firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; + while (--n > 0) { + lastPtr = lastPtr->nextBlock; } + cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; + cachePtr->buckets[bucket].numFree -= numMove; - 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]); + /* + * Aquire the lock and place the list of blocks at the front of the shared + * cache bucket. + */ - Tcl_MutexUnlock(allocMutexPtr); + LockBucket(cachePtr, bucket); + lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; + sharedPtr->buckets[bucket].firstPtr = firstPtr; + sharedPtr->buckets[bucket].numFree += numMove; + UnlockBucket(cachePtr, bucket); } #endif - -#else /* !USE_TCLALLOC */ /* *---------------------------------------------------------------------- * - * TclpAlloc -- + * GetBlocks -- * - * Allocate more memory. + * Get more blocks for a bucket. * * Results: - * None. + * 1 if blocks where allocated, 0 otherwise. * * Side effects: - * None. + * Cache may be filled with available blocks. * *---------------------------------------------------------------------- */ -char * -TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ +static int +GetBlocks( + Cache *cachePtr, + int bucket) { - return (char *) malloc(numBytes); + register Block *blockPtr = NULL; + register int n; + + if (allocator == aPURIFY) { + if (bucket) { + Tcl_Panic("purify mode asking for blocks?"); + } + cachePtr->buckets[0].firstPtr = (Block *) calloc(1, MINALLOC); + cachePtr->buckets[0].numFree = 1; + return 1; + } + +#if defined(TCL_THREADS) + /* + * 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); + } +#endif + + if (cachePtr->buckets[bucket].numFree == 0) { + register size_t size; + +#if TCL_ALLOCATOR != aNATIVE + /* + * If no blocks could be moved from shared, first look for a larger + * block in this cache OR the shared cache to split up. + */ + + n = nBuckets; + size = 0; /* lint */ + while (--n > bucket) { + size = bucketInfo[n].blockSize; + if (cachePtr->buckets[n].numFree > 0) { + blockPtr = cachePtr->buckets[n].firstPtr; + cachePtr->buckets[n].firstPtr = blockPtr->nextBlock; + cachePtr->buckets[n].numFree--; + break; + } else if (sharedPtr->buckets[n].numFree > 0){ + LockBucket(cachePtr, n); + if (sharedPtr->buckets[n].numFree > 0) { + blockPtr = sharedPtr->buckets[n].firstPtr; + sharedPtr->buckets[n].firstPtr = blockPtr->nextBlock; + sharedPtr->buckets[n].numFree--; + UnlockBucket(cachePtr, n); + break; + } + UnlockBucket(cachePtr, n); + } + } +#endif + + /* + * 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; } /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- * - * TclpFree -- + * TclInitAlloc -- * - * Free memory. + * Initialize the memory system. * * Results: * None. * * Side effects: - * None. + * Initialize the mutex used to serialize allocations. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- */ void -TclpFree( - char *oldPtr) /* Pointer to memory to free. */ +TclInitAlloc(void) { - free(oldPtr); - return; } /* *---------------------------------------------------------------------- * - * TclpRealloc -- + * TclFinalizeAlloc -- * - * Reallocate memory. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. @@ -745,16 +1254,55 @@ TclpFree( *---------------------------------------------------------------------- */ -char * -TclpRealloc( - char *oldPtr, /* Pointer to alloced block. */ - unsigned int numBytes) /* New size of memory. */ +void +TclFinalizeAlloc(void) { - return (char *) realloc(oldPtr, numBytes); +#if defined(TCL_THREADS) + 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); +#endif } + +#if TCL_ALLOCATOR != aZIPPY +static void +ChooseAllocator() +{ + char *choice = getenv("TCL_ALLOCATOR"); + + /* + * This is only called with ALLOCATOR_BASE aZIPPY (when compiled with + * aMULTI) or aNATIVE (when compiled with aNATIVE). + */ + + allocator = ALLOCATOR_BASE; + + if (choice) { + /* + * Only override the base when requesting native or purify + */ + + if (!strcmp(choice, "aNATIVE")) { + allocator = aNATIVE; + } else if (!strcmp(choice, "aPURIFY")) { + allocator = aPURIFY; + } + } +} +#endif -#endif /* !USE_TCLALLOC */ -#endif /* !TCL_THREADS */ +#endif /* end of !PURIFY */ /* * Local Variables: diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 754941f..2562558 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1095,11 +1095,9 @@ NewAssemblyEnv( * 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; @@ -1144,11 +1142,6 @@ 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 */ @@ -1191,8 +1184,8 @@ FreeAssemblyEnv( * Dispose what's left. */ - TclStackFree(interp, assemEnvPtr->parsePtr); - TclStackFree(interp, assemEnvPtr); + ckfree(assemEnvPtr->parsePtr); + ckfree(assemEnvPtr); } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5f2b301..5e676ba 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -728,11 +728,6 @@ Tcl_CreateInterp(void) * 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; @@ -2319,8 +2314,7 @@ TclInvokeStringCommand( { 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]); @@ -2333,7 +2327,7 @@ TclInvokeStringCommand( result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); return result; } @@ -2368,8 +2362,7 @@ TclInvokeObjectCommand( 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]); @@ -2405,7 +2398,7 @@ TclInvokeObjectCommand( objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } - TclStackFree(interp, objv); + ckfree(objv); return result; } @@ -4563,7 +4556,7 @@ TEOV_NotFound( 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 @@ -4602,7 +4595,7 @@ TEOV_NotFound( for (i = 0; i < handlerObjc; ++i) { Tcl_DecrRefCount(newObjv[i]); } - TclStackFree(interp, newObjv); + ckfree(newObjv); return TCL_ERROR; } @@ -4640,7 +4633,7 @@ TEOV_NotFoundCallback( for (i = 0; i < objc; ++i) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(interp, objv); + ckfree(objv); return result; } @@ -4937,12 +4930,11 @@ TclEvalEx( * 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 @@ -5338,11 +5330,11 @@ TclEvalEx( 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; } @@ -5980,7 +5972,7 @@ TclNREvalObjEx( * 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; @@ -6098,7 +6090,7 @@ TclNREvalObjEx( */ int pc = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame)); *ctxPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { @@ -6139,7 +6131,7 @@ TclNREvalObjEx( Tcl_DecrRefCount(ctxPtr->data.eval.path); } - TclStackFree(interp, ctxPtr); + ckfree(ctxPtr); } /* @@ -6218,7 +6210,7 @@ TEOEx_ListCallback( if (eoFramePtr) { iPtr->cmdFramePtr = eoFramePtr->nextPtr; - TclStackFree(interp, eoFramePtr); + ckfree(eoFramePtr); } TclDecrRefCount(listPtr); diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 9d63ebf..3b51f68 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -1296,10 +1296,6 @@ TclFinalizeMemorySubsystem(void) Tcl_MutexUnlock(ckallocMutexPtr); #endif - -#if USE_TCLALLOC - TclFinalizeAllocSubsystem(); -#endif } /* diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 3edfa54..b4afdef 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2348,7 +2348,7 @@ TclNRForObjCmd( return TCL_ERROR; } - TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); + TclCkSmallAlloc(sizeof(ForIterData), iterPtr); iterPtr->cond = objv[2]; iterPtr->body = objv[4]; iterPtr->next = objv[3]; @@ -2376,7 +2376,7 @@ ForSetupCallback( 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); @@ -2414,7 +2414,7 @@ TclNRForIterCallback( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(iterPtr->msg, Tcl_GetErrorLine(interp))); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } @@ -2431,11 +2431,11 @@ ForCondCallback( 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); @@ -2452,7 +2452,7 @@ ForCondCallback( return TclNREvalObjEx(interp, iterPtr->body, 0, iPtr->cmdFramePtr, iterPtr->word); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } @@ -2492,7 +2492,7 @@ ForPostNextCallback( 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; } @@ -2560,7 +2560,7 @@ TclNRForeachCmd( * 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, @@ -2754,7 +2754,7 @@ ForeachCleanup( TclDecrRefCount(statePtr->aCopyList[i]); } } - TclStackFree(interp, statePtr); + ckfree(statePtr); } /* diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b38ec9f..cd4a72b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1313,7 +1313,7 @@ TclInfoFrame( * 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; @@ -1347,7 +1347,7 @@ TclInfoFrame( ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); - TclStackFree(interp, fPtr); + ckfree(fPtr); break; } @@ -3016,7 +3016,7 @@ Tcl_LsearchObjCmd( int j; if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } if (i > objc-4) { if (startPtr != NULL) { @@ -3051,7 +3051,7 @@ Tcl_LsearchObjCmd( break; default: sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + ckalloc(sizeof(int) * sortInfo.indexc); } /* @@ -3158,7 +3158,7 @@ Tcl_LsearchObjCmd( if (offset > listc-1) { if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); @@ -3483,7 +3483,7 @@ Tcl_LsearchObjCmd( done: if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } return result; } @@ -3770,7 +3770,7 @@ Tcl_LsortObjCmd( 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. */ } @@ -3865,6 +3865,7 @@ Tcl_LsortObjCmd( /* * Do not shrink the actual memory block used; that doesn't * work with TclStackAlloc-allocated memory. [Bug 2918962] + * FIXME: TclStackAlloc is now retired, we could shrink it. */ for (i = 0; i < sortInfo.indexc; i++) { @@ -3902,7 +3903,7 @@ Tcl_LsortObjCmd( * begins sorting it into the sublists as it appears. */ - elementArray = TclStackAlloc(interp, length * sizeof(SortElement)); + elementArray = ckalloc(length * sizeof(SortElement)); for (i=0; i < length; i++){ idx = groupSize * i + groupOffset; @@ -4026,7 +4027,7 @@ Tcl_LsortObjCmd( } done1: - TclStackFree(interp, elementArray); + ckfree(elementArray); done: if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -4036,7 +4037,7 @@ Tcl_LsortObjCmd( } done2: if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } return sortInfo.resultCode; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 05f2e5d..d85cd83 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1835,7 +1835,7 @@ StringMapCmd( * 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) { @@ -3966,7 +3966,7 @@ SwitchPostProc( (overflow ? limit : patternLength), pattern, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } - TclStackFree(interp, ctxPtr); + ckfree(ctxPtr); return result; } @@ -4729,7 +4729,7 @@ TclNRWhileObjCmd( * 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; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 083f530..2fda2b9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1021,8 +1021,7 @@ TclCompileDictUpdateCmd( 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 TCL_ERROR; } bodyTokenPtr = tokenPtr; @@ -1124,7 +1123,7 @@ TclCompileDictUpdateCmd( Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - TclStackFree(interp, keyTokenPtrs); + ckfree(keyTokenPtrs); return TCL_OK; } @@ -1637,10 +1636,9 @@ TclCompileForeachCmd( */ 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 **)); /* @@ -1867,8 +1865,8 @@ TclCompileForeachCmd( ckfree(varvList[loopIndex]); } } - TclStackFree(interp, (void *)varvList); - TclStackFree(interp, varcList); + ckfree((void *)varvList); + ckfree(varcList); return code; } @@ -3516,7 +3514,7 @@ TclCompileReturnCmd( * 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, @@ -3540,7 +3538,7 @@ TclCompileReturnCmd( 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, @@ -4028,7 +4026,7 @@ PushVarName( * 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; @@ -4081,7 +4079,7 @@ PushVarName( * token. */ - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); + elemTokenPtr = ckalloc(n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; @@ -4169,7 +4167,7 @@ PushVarName( varTokenPtr[removedParen].size++; } if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); + ckfree(elemTokenPtr); } *localIndexPtr = localIndex; *simpleVarNamePtr = simpleVarName; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d956819..ff494f2 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -595,7 +595,7 @@ TclCompileSubstCmd( 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(); @@ -628,7 +628,7 @@ TclCompileSubstCmd( while (--objc >= 0) { TclDecrRefCount(objv[objc]); } - TclStackFree(interp, objv); + ckfree(objv); if (/*toSubst == NULL*/ code != TCL_OK) { return TCL_ERROR; } @@ -1320,8 +1320,8 @@ IssueSwitchChainedTests( 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; @@ -1520,8 +1520,8 @@ IssueSwitchChainedTests( } } } - TclStackFree(interp, fixupTargetArray); - TclStackFree(interp, fixupArray); + ckfree(fixupTargetArray); + ckfree(fixupArray); envPtr->currStackDepth = savedStackDepth + 1; } @@ -1582,7 +1582,7 @@ IssueSwitchJumpTable( 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; @@ -1720,7 +1720,7 @@ IssueSwitchJumpTable( * Clean up all our temporary space and return. */ - TclStackFree(interp, finalFixups); + ckfree(finalFixups); } /* @@ -1975,12 +1975,12 @@ TclCompileTryCmd( 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 ; itype = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; @@ -2953,7 +2953,7 @@ PushVarName( * token. */ - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); + elemTokenPtr = ckalloc(n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; @@ -3041,7 +3041,7 @@ PushVarName( varTokenPtr[removedParen].size++; } if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); + ckfree(elemTokenPtr); } *localIndexPtr = localIndex; *simpleVarNamePtr = simpleVarName; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index a07d6df..396448b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -920,7 +920,7 @@ ParseExpr( case SCRIPT: { Tcl_Parse *nestedPtr = - TclStackAlloc(interp, sizeof(Tcl_Parse)); + ckalloc(sizeof(Tcl_Parse)); tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; @@ -955,7 +955,7 @@ ParseExpr( break; } } - TclStackFree(interp, nestedPtr); + ckfree(nestedPtr); end = start; start = tokenPtr->start; scanned = end - start; @@ -1821,7 +1821,7 @@ Tcl_ParseExpr( 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) { @@ -1843,7 +1843,7 @@ Tcl_ParseExpr( } Tcl_FreeParse(exprParsePtr); - TclStackFree(interp, exprParsePtr); + ckfree(exprParsePtr); ckfree(opTree); return code; } @@ -2072,7 +2072,7 @@ TclCompileExpr( 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, @@ -2100,7 +2100,7 @@ TclCompileExpr( } Tcl_FreeParse(parsePtr); - TclStackFree(interp, parsePtr); + ckfree(parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree(opTree); @@ -2143,7 +2143,7 @@ ExecConstantExprTree( * 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 */); @@ -2151,7 +2151,7 @@ ExecConstantExprTree( Tcl_IncrRefCount(byteCodeObj); TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); - TclStackFree(interp, envPtr); + ckfree(envPtr); byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); @@ -2208,10 +2208,10 @@ CompileExprTree( 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; @@ -2219,13 +2219,13 @@ CompileExprTree( 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; @@ -2331,10 +2331,10 @@ CompileExprTree( 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: @@ -2358,13 +2358,13 @@ CompileExprTree( 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); @@ -2541,9 +2541,8 @@ TclSortingOpCmd( 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; @@ -2583,8 +2582,8 @@ TclSortingOpCmd( code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr); - TclStackFree(interp, nodes); - TclStackFree(interp, litObjv); + ckfree(nodes); + ckfree(litObjv); } return code; } @@ -2670,7 +2669,7 @@ TclVariadicOpCmd( 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; @@ -2703,7 +2702,7 @@ TclVariadicOpCmd( code = ExecConstantExprTree(interp, nodes, 0, &litObjv); - TclStackFree(interp, nodes); + ckfree(nodes); return code; } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index aed9e3b..4d6bf33 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1202,7 +1202,7 @@ TclInitCompileEnv( * ...) which may make change the type as well. */ - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame)); int pc = 0; *ctxPtr = *invoker; @@ -1255,7 +1255,7 @@ TclInitCompileEnv( } } - TclStackFree(interp, ctxPtr); + ckfree(ctxPtr); } envPtr->extCmdMapPtr->start = envPtr->line; @@ -1461,7 +1461,7 @@ TclCompileScript( /* 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); @@ -1877,7 +1877,7 @@ TclCompileScript( } envPtr->numSrcBytes = p - script; - TclStackFree(interp, parsePtr); + ckfree(parsePtr); Tcl_DStringFree(&ds); } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3da91a3..4ed3fe6 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2425,14 +2425,14 @@ DictForNRCmd( TCL_STATIC); 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); @@ -2488,7 +2488,7 @@ DictForNRCmd( TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return TCL_ERROR; } @@ -2574,7 +2574,7 @@ DictForLoopCallback( TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return result; } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 78bd7b8..49e8137 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1032,9 +1032,7 @@ TclInitSubsystems(void) 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 @@ -1211,9 +1209,7 @@ Tcl_Finalize(void) * Close down the thread-specific object allocator. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAlloc(); -#endif + TclFinalizeAlloc(); /* * We defer unloading of packages until very late to avoid memory access diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 26d3e04..b340144 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -171,19 +171,21 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { 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 */ + int catchDepth; /* this level: they record the state when a */ int cleanup; /* new codePtr was received for NR */ Tcl_Obj *auxObjList; /* execution. */ int checkInterp; CmdFrame cmdFrame; + unsigned int capacity; void * stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ } TEBCdata; #define TEBC_YIELD() \ - esPtr->tosPtr = tosPtr; \ + TD->tosPtr = tosPtr; \ TD->pc = pc; \ TD->cleanup = cleanup; \ TclNRAddCallback(interp, TEBCresume, TD, \ @@ -192,7 +194,7 @@ typedef struct TEBCdata { #define TEBC_DATA_DIG() \ pc = TD->pc; \ cleanup = TD->cleanup; \ - tosPtr = esPtr->tosPtr + tosPtr = TD->tosPtr #define PUSH_TAUX_OBJ(objPtr) \ @@ -296,20 +298,6 @@ VarHashCreateVar( } 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 @@ -683,7 +671,6 @@ static void ValidatePcAndStackTop(ByteCode *codePtr, int stackLowerBound, 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, @@ -699,16 +686,10 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, 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; @@ -845,10 +826,7 @@ TclCreateExecEnv( * [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); @@ -858,12 +836,6 @@ TclCreateExecEnv( 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(); @@ -892,42 +864,14 @@ TclCreateExecEnv( *---------------------------------------------------------------------- */ -static void -DeleteExecStack( - ExecStack *esPtr) -{ - if (esPtr->markerPtr) { - 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; - /* * 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) { @@ -967,339 +911,6 @@ TclFinalizeExecution(void) } /* - * 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 { - 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; - } - } - - /* - * 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. - */ - - newElems = 2*currElems; - while (needed > newElems) { - newElems *= 2; - } - 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) { - Tcl_Free((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; - } 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 *) Tcl_Alloc(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 *) Tcl_Realloc((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 -- @@ -1697,7 +1308,7 @@ TclCompileObj( int redo = 0; if (invoker) { - CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); + CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame)); *ctxPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { @@ -1736,7 +1347,7 @@ TclCompileObj( && (ctxPtr->type == TCL_LOCATION_SOURCE)); } - TclStackFree(interp, ctxPtr); + ckfree(ctxPtr); } if (redo) { @@ -1921,9 +1532,8 @@ TclIncrObj( *---------------------------------------------------------------------- */ #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]) int TclNRExecuteByteCode( @@ -1932,10 +1542,8 @@ TclNRExecuteByteCode( { 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 *); + unsigned int size = sizeof(TEBCdata) + sizeof(void *) * + (codePtr->maxStackDepth + codePtr->maxExceptDepth - 1); if (iPtr->execEnvPtr->rewind) { return TCL_ERROR; @@ -1955,15 +1563,16 @@ TclNRExecuteByteCode( * execution stack is large enough to execute this ByteCode. */ - TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); - esPtr->tosPtr = initTosPtr; + TD = ckalloc(size); + TD->tosPtr = initTosPtr; TD->codePtr = codePtr; TD->pc = codePtr->codeStart; - TD->catchTop = initCatchTop; + 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 @@ -2048,11 +1657,11 @@ TEBCresume( 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() */ + * is necessary. Set by checkInterp = 1 */ /* * Globals: variables that store state, must remain valid at all times. @@ -2113,7 +1722,7 @@ TEBCresume( codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - CACHE_STACK_INFO(); + checkInterp = 1; if (result == TCL_OK) { #ifndef TCL_COMPILE_DEBUG if (*pc == INST_POP) { @@ -2253,29 +1862,28 @@ TEBCresume( */ 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; } TCL_DTRACE_INST_NEXT(); @@ -2643,7 +2251,7 @@ TEBCresume( 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 @@ -2657,7 +2265,6 @@ TEBCresume( Tcl_GetObjResult(interp)); goto gotError; } - (void) POP_OBJECT(); /* * Make sure there is enough room in the stack to expand this list @@ -2666,24 +2273,26 @@ TEBCresume( * 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); + 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; - catchTop += moved; - tosPtr += moved; + (void) POP_OBJECT(); + if (reqWords > TD->capacity) { + ptrdiff_t depth; + unsigned int size = sizeof(TEBCdata) + sizeof(void *) * + + (reqWords + codePtr->maxExceptDepth - 1); + + depth = tosPtr - initTosPtr; + TD = ckrealloc(TD, size); + tosPtr = initTosPtr + depth; + TD->capacity = reqWords; } - + /* * Expand the list at stacktop onto the stack; free the list. Knowing * that it has a freeIntRepProc we use Tcl_DecrRefCount(). @@ -2702,9 +2311,8 @@ TEBCresume( 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(); @@ -2790,8 +2398,6 @@ TEBCresume( codePtr, bcFramePtr, pc - codePtr->codeStart); } - DECACHE_STACK_INFO(); - pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, @@ -3016,10 +2622,9 @@ TEBCresume( * 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; @@ -3263,10 +2868,9 @@ TEBCresume( 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; @@ -3527,10 +3131,9 @@ TEBCresume( } 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", @@ -3562,10 +3165,9 @@ TEBCresume( } 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; @@ -3598,10 +3200,9 @@ TEBCresume( 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); @@ -3631,10 +3232,9 @@ TEBCresume( /*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); @@ -3678,12 +3278,11 @@ TEBCresume( } 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: @@ -3720,7 +3319,6 @@ TEBCresume( } } slowUnsetArray: - DECACHE_STACK_INFO(); varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", 0, 0, arrayPtr, opnd); if (!varPtr) { @@ -3731,7 +3329,7 @@ TEBCresume( 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: @@ -3751,16 +3349,15 @@ TEBCresume( 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; @@ -3781,9 +3378,8 @@ TEBCresume( } 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); } @@ -4024,18 +3620,16 @@ TEBCresume( 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; } @@ -4812,9 +4406,8 @@ TEBCresume( 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; } @@ -4823,9 +4416,8 @@ TEBCresume( 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; } @@ -4883,11 +4475,10 @@ TEBCresume( Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); #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) { @@ -4931,11 +4522,10 @@ TEBCresume( Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); #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) { @@ -4955,10 +4545,9 @@ TEBCresume( "integer value too large to represent", TCL_STATIC); #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 { @@ -5041,9 +4630,8 @@ TEBCresume( 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; } @@ -5062,9 +4650,8 @@ TEBCresume( 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; } @@ -5211,9 +4798,8 @@ TEBCresume( 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. */ @@ -5231,9 +4817,8 @@ TEBCresume( 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) { @@ -5258,9 +4843,8 @@ TEBCresume( || 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) { @@ -5304,9 +4888,8 @@ TEBCresume( 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; } @@ -5322,9 +4905,8 @@ TEBCresume( 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. @@ -5332,9 +4914,8 @@ TEBCresume( TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", O2S(objResultPtr))); - DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); - CACHE_STACK_INFO(); + checkInterp = 1; } goto gotError; } @@ -5379,9 +4960,8 @@ TEBCresume( case INST_BREAK: /* - DECACHE_STACK_INFO(); Tcl_ResetResult(interp); - CACHE_STACK_INFO(); + checkInterp = 1; */ result = TCL_BREAK; cleanup = 0; @@ -5389,9 +4969,8 @@ TEBCresume( case INST_CONTINUE: /* - DECACHE_STACK_INFO(); Tcl_ResetResult(interp); - CACHE_STACK_INFO(); + checkInterp = 1; */ result = TCL_CONTINUE; cleanup = 0; @@ -5524,17 +5103,16 @@ TEBCresume( 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++; } @@ -5566,19 +5144,18 @@ TEBCresume( * 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: @@ -5600,9 +5177,8 @@ TEBCresume( 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); @@ -5654,13 +5230,12 @@ TEBCresume( TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd+1, 1); } - DECACHE_STACK_INFO(); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), "\" not known in dictionary", NULL); 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 { TRACE_WITH_OBJ(( @@ -5683,9 +5258,8 @@ TEBCresume( 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); @@ -5757,10 +5331,9 @@ TEBCresume( 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", @@ -5787,9 +5360,8 @@ TEBCresume( 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); @@ -5893,10 +5465,9 @@ TEBCresume( 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", @@ -5998,10 +5569,9 @@ TEBCresume( 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; } @@ -6022,7 +5592,6 @@ TEBCresume( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - DECACHE_STACK_INFO(); if (valuePtr == NULL) { TclObjUnsetVar2(interp, localName(iPtr->varFramePtr, duiPtr->varIndices[i]), @@ -6030,10 +5599,10 @@ TEBCresume( } 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); @@ -6049,9 +5618,8 @@ TEBCresume( 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); @@ -6077,10 +5645,9 @@ TEBCresume( 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]); @@ -6096,10 +5663,9 @@ TEBCresume( 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); @@ -6215,10 +5781,9 @@ TEBCresume( */ divideByZero: - DECACHE_STACK_INFO(); Tcl_SetResult(interp, "divide by zero", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; /* @@ -6227,12 +5792,11 @@ TEBCresume( */ exponOfZero: - DECACHE_STACK_INFO(); 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 @@ -6258,9 +5822,8 @@ TEBCresume( 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; @@ -6270,8 +5833,8 @@ TEBCresume( */ while (auxObjList) { - if ((catchTop != initCatchTop) && (*catchTop > - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { + if ((catchDepth >=0) && (PTR2INT(catchStack[catchDepth]) > + PTR2INT(auxObjList->internalRep.twoPtrValue.ptr1))) { break; } POP_TAUX_OBJ(); @@ -6311,7 +5874,7 @@ TEBCresume( #endif goto abnormalReturn; } - if (catchTop == initCatchTop) { + if (catchDepth == -1) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", @@ -6346,16 +5909,16 @@ TEBCresume( */ 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); @@ -6404,7 +5967,7 @@ TEBCresume( if (--codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - TclStackFree(interp, TD); /* free my stack */ + ckfree(TD); /* free my stack */ return result; } @@ -6412,10 +5975,9 @@ TEBCresume( #undef codePtr #undef iPtr #undef bcFramePtr -#undef initCatchTop #undef initTosPtr #undef auxObjList -#undef catchTop +#undef catchDepth #undef TCONST /* diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 6d3c013..52ad278 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -999,7 +999,7 @@ TclFileAttrsCmd( 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); @@ -1110,7 +1110,7 @@ TclFileAttrsCmd( * Free up the array we allocated. */ - TclStackFree(interp, (void *) attributeStringsAllocated); + ckfree((void *) attributeStringsAllocated); /* * We don't need this object that was passed to us any more. diff --git a/generic/tclFileName.c b/generic/tclFileName.c index d53c271..eff1010 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1422,7 +1422,7 @@ Tcl_GlobObjCmd( 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; @@ -1638,7 +1638,7 @@ Tcl_GlobObjCmd( if (globTypes->macCreator != NULL) { Tcl_DecrRefCount(globTypes->macCreator); } - TclStackFree(interp, globTypes); + ckfree(globTypes); } return result; } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 1f0e4a9..ffa172a 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -929,7 +929,7 @@ Tcl_ExecObjCmd( */ 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 @@ -947,7 +947,7 @@ Tcl_ExecObjCmd( * Free the argv array. */ - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); if (chan == NULL) { return TCL_ERROR; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index d98842e..f9511af 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -952,12 +952,12 @@ Tcl_WrongNumArgs( len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, (unsigned)len); + char *quotedElementStr = ckalloc((unsigned)len); len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); - TclStackFree(interp, quotedElementStr); + ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } @@ -1006,12 +1006,12 @@ Tcl_WrongNumArgs( len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp,(unsigned) len); + char *quotedElementStr = ckalloc((unsigned) len); len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); - TclStackFree(interp, quotedElementStr); + ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index df60dae..6330836 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -35,9 +35,9 @@ scspec EXTERN #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) @@ -867,12 +867,12 @@ declare 213 { 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) diff --git a/generic/tclInt.h b/generic/tclInt.h index 42e2212..45eaf7e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -10,7 +10,7 @@ * 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. @@ -1390,13 +1390,6 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *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. @@ -1438,19 +1431,6 @@ 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 @@ -1487,8 +1467,6 @@ typedef struct CoroutineData { } 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; @@ -1769,24 +1747,6 @@ enum PkgPreferOptions { /* *---------------------------------------------------------------- - * 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 @@ -2118,7 +2078,6 @@ typedef struct Interp { * 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 */ @@ -2351,17 +2310,6 @@ struct LimitHandler { #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 @@ -2902,7 +2850,6 @@ MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); -MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); @@ -2919,7 +2866,6 @@ 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); @@ -3097,8 +3043,6 @@ 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, @@ -3808,10 +3752,10 @@ typedef const char *TclDTraceStr; #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) \ @@ -3846,128 +3790,122 @@ typedef const char *TclDTraceStr; } \ } -#if defined(PURIFY) +#else /* TCL_MEM_DEBUG */ +MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, + int line); -/* - * 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 TclDbNewObj(objPtr, file, line) \ + do { \ + TclIncrObjsAllocated(); \ + (objPtr) = (Tcl_Obj *) \ + Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ + TclDbInitNewObj((objPtr), (file), (line)); \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) -# define TclAllocObjStorageEx(interp, objPtr) \ - (objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj)) +# define TclNewObj(objPtr) \ + TclDbNewObj(objPtr, __FILE__, __LINE__); -# define TclFreeObjStorageEx(interp, objPtr) \ - ckfree((char *) (objPtr)) +# define TclDecrRefCount(objPtr) \ + Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) -#undef USE_THREAD_ALLOC -#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +# define TclNewListObjDirect(objc, objv) \ + TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__) + +#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 Tcl_Obj * TclThreadAllocObj(void); -MODULE_SCOPE void TclThreadFreeObj(Tcl_Obj *); -MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); -MODULE_SCOPE void TclFreeAllocCache(void *); +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 void TclpFreeAllocCache(void *); +MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); +#endif /* - * 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. + * List of valid allocators. Have to respect the following convention: + * - allocators that shunt TclpAlloc to malloc are below aNONE + * - allocators that use zippy are above aNONE */ -# define ALLOC_NOBJHIGH 1200 +#define aNATIVE 0 +#define aPURIFY 1 +#define aNONE 2 +#define aZIPPY 3 +#define aMULTI 4 -# 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.otherValuePtr; \ - --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.otherValuePtr = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = objPtr; \ - ++cachePtr->numObjects; \ - } \ - } while (0) - -#else /* not PURIFY or USE_THREAD_ALLOC */ +#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI)) +#undef TCL_ALLOCATOR +#endif -#ifdef TCL_THREADS -/* declared in tclObj.c */ -MODULE_SCOPE Tcl_Mutex tclObjMutex; +#ifdef PURIFY +# undef TCL_ALLOCATOR +# define TCL_ALLOCATOR aPURIFY #endif -# define TclAllocObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ - if (tclFreeObjList == NULL) { \ - TclAllocateFreeObjects(); \ - } \ - (objPtr) = tclFreeObjList; \ - tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.otherValuePtr; \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) +#if !defined(TCL_ALLOCATOR) +# if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC) +# define TCL_ALLOCATOR aZIPPY +# else +# define TCL_ALLOCATOR aNATIVE +# endif +#endif -# define TclFreeObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ - (objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) +#if TCL_ALLOCATOR < aNONE /* native or purify */ +# define TclpAlloc(size) ckalloc(size) +# define TclpRealloc(ptr, size) ckrealloc((ptr),(size)) +# define TclpFree(size) ckfree(size) +#else + MODULE_SCOPE char * TclpAlloc(unsigned int size); + MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size); + MODULE_SCOPE void TclpFree(char * ptr); #endif -#else /* TCL_MEM_DEBUG */ -MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, - int line); +#if TCL_ALLOCATOR == aPURIFY +# define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj)) +# define TclSmallFree(ptr) ckfree(ptr) +# define TclInitAlloc() +# define TclFinalizeAlloc() +#else + MODULE_SCOPE void * TclSmallAlloc(); + MODULE_SCOPE void TclSmallFree(void *ptr); + MODULE_SCOPE void TclInitAlloc(void); + MODULE_SCOPE void TclFinalizeAlloc(void); +#endif -# define TclDbNewObj(objPtr, file, line) \ - do { \ - TclIncrObjsAllocated(); \ - (objPtr) = (Tcl_Obj *) \ - Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ - TclDbInitNewObj((objPtr), (file), (line)); \ - TCL_DTRACE_OBJ_CREATE(objPtr); \ +#define TclCkSmallAlloc(nbytes, memPtr) \ + do { \ + TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ + memPtr = TclSmallAlloc(); \ } while (0) -# define TclNewObj(objPtr) \ - TclDbNewObj(objPtr, __FILE__, __LINE__); +/* + * Support for Clang Static Analyzer + */ -# define TclDecrRefCount(objPtr) \ - Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) +#if (TCL_ALLOCATOR == aPURIFY) && 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__ */ -# define TclNewListObjDirect(objc, objv) \ - TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__) -#undef USE_THREAD_ALLOC -#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------- @@ -4471,73 +4409,11 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; {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__ */ + /* *---------------------------------------------------------------- @@ -4610,8 +4486,8 @@ typedef struct NRE_callback { #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)))) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index b294e4f..0966d32 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -58,8 +58,7 @@ /* 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, @@ -506,10 +505,8 @@ 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, @@ -609,7 +606,7 @@ typedef struct TclIntStubs { 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 */ @@ -821,8 +818,8 @@ typedef struct TclIntStubs { 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); @@ -876,8 +873,7 @@ extern const TclIntStubs *tclIntStubsPtr; /* 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 */ @@ -1216,10 +1212,8 @@ extern const TclIntStubs *tclIntStubsPtr; (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 \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 67761ed..46a5f42 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1169,7 +1169,7 @@ Tcl_CreateAlias( 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]); @@ -1187,7 +1187,7 @@ Tcl_CreateAlias( for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(slaveInterp, objv); + ckfree(objv); Tcl_DecrRefCount(targetObjPtr); Tcl_DecrRefCount(slaveObjPtr); @@ -1863,7 +1863,7 @@ AliasObjCmd( if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + cmdv = ckalloc(cmdc * sizeof(Tcl_Obj *)); } prefv = &aliasPtr->objPtr; @@ -1930,7 +1930,7 @@ AliasObjCmd( Tcl_DecrRefCount(cmdv[i]); } if (cmdv != cmdArr) { - TclStackFree(interp, cmdv); + ckfree(cmdv); } return result; #undef ALIAS_CMDV_PREALLOC diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index ad233b9..08a9443 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -465,7 +465,7 @@ TclPushStackFrame( * treated as references to namespace * variables. */ { - *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame)); + *framePtrPtr = ckalloc(sizeof(CallFrame)); return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); } @@ -477,7 +477,7 @@ TclPopStackFrame( CallFrame *freePtr = ((Interp *) interp)->framePtr; Tcl_PopCallFrame(interp); - TclStackFree(interp, freePtr); + ckfree(freePtr); } /* @@ -2632,8 +2632,7 @@ TclResetShadowedCmdRefs( 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 @@ -2722,13 +2721,12 @@ TclResetShadowedCmdRefs( 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); } /* @@ -3970,8 +3968,7 @@ NamespacePathCmd( 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); - TclStackFree(oPtr->fPtr->interp, contextPtr); + ckfree(contextPtr); DelRef(oPtr); } @@ -1087,7 +1087,7 @@ TclOOGetCallContext( } returnContext: - contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); + contextPtr = ckalloc(sizeof(CallContext)); contextPtr->oPtr = oPtr; AddRef(oPtr); contextPtr->callPtr = callPtr; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 8d8eb85..cc3a0ad 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -455,7 +455,7 @@ TclOOUnknownDefinition( * 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); @@ -465,7 +465,7 @@ TclOOUnknownDefinition( } result = Tcl_EvalObjv(interp, objc-1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); - TclStackFree(interp, newObjv); + ckfree(newObjv); return result; } @@ -1546,7 +1546,7 @@ TclOODefineMixinObjCmd( Tcl_AppendResult(interp, "attempt to misuse API", 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; } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 112d663..0996eab 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -686,7 +686,7 @@ InvokeProcedureMethod( * Allocate the special frame data. */ - fdPtr = TclStackAlloc(interp, sizeof(PMFrameData)); + fdPtr = ckalloc(sizeof(PMFrameData)); /* * Create a call frame for this method. @@ -695,7 +695,7 @@ InvokeProcedureMethod( result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr, objc, objv, fdPtr); if (result != TCL_OK) { - TclStackFree(interp, fdPtr); + ckfree(fdPtr); return result; } pmPtr->refCount++; @@ -719,11 +719,11 @@ InvokeProcedureMethod( 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; } } @@ -774,7 +774,7 @@ FinalizePMCall( if (--pmPtr->refCount < 1) { DeleteProcedureMethodRecord(pmPtr); } - TclStackFree(interp, fdPtr); + ckfree(fdPtr); return result; } @@ -1447,7 +1447,7 @@ FinalizeForwardCall( { Tcl_Obj **argObjs = data[0]; - TclStackFree(interp, argObjs); + ckfree(argObjs); return result; } @@ -1576,7 +1576,7 @@ InitEnsembleRewrite( 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)); diff --git a/generic/tclObj.c b/generic/tclObj.c index 3bc6f12..5056c1c 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -27,12 +27,6 @@ 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. */ @@ -475,7 +469,7 @@ TclFinalizeThreadObjects(void) * TclFinalizeObjects -- * * This function is called by Tcl_Finalize to clean up all registered - * Tcl_ObjType's and to reset the tclFreeObjList. + * Tcl_ObjType's * * Results: * None. @@ -495,15 +489,6 @@ TclFinalizeObjects(void) 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); } /* @@ -1238,59 +1223,6 @@ Tcl_DbNewObj( /* *---------------------------------------------------------------------- * - * 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.otherValuePtrs. - * - *---------------------------------------------------------------------- - */ - -#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.otherValuePtr = prevPtr; - prevPtr = objPtr; - objPtr++; - } - tclFreeObjList = prevPtr; -} -#undef OBJS_TO_ALLOC_EACH_TIME - -/* - *---------------------------------------------------------------------- - * * TclFreeObj -- * * This function frees the memory associated with the argument object. @@ -1404,7 +1336,6 @@ TclFreeObj( */ TclInvalidateStringRep(objPtr); - objPtr->length = -1; if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* diff --git a/generic/tclParse.c b/generic/tclParse.c index 9bfe608..afd4c0b 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1129,14 +1129,14 @@ ParseTokens( 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; @@ -1162,11 +1162,11 @@ ParseTokens( 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++; @@ -1526,10 +1526,10 @@ Tcl_ParseVar( { 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; } @@ -1541,13 +1541,13 @@ Tcl_ParseVar( * 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; } @@ -2008,7 +2008,7 @@ TclSubstParse( 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)) { @@ -2026,7 +2026,7 @@ TclSubstParse( } lastTerm = nestedPtr->term; } - TclStackFree(interp, nestedPtr); + ckfree(nestedPtr); if (lastTerm == parsePtr->term) { /* diff --git a/generic/tclProc.c b/generic/tclProc.c index 6cd5bb2..63dd61d 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -222,7 +222,7 @@ Tcl_ProcObjCmd( */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr = ckalloc(sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; if (contextPtr->type == TCL_LOCATION_BC) { @@ -300,7 +300,7 @@ Tcl_ProcObjCmd( Tcl_DecrRefCount(contextPtr->data.eval.path); contextPtr->data.eval.path = NULL; } - TclStackFree(interp, contextPtr); + ckfree(contextPtr); } /* @@ -1096,8 +1096,7 @@ ProcWrongNumArgs( */ 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); @@ -1135,7 +1134,7 @@ ProcWrongNumArgs( for (i=0 ; i<=numArgs ; i++) { Tcl_DecrRefCount(desiredObjs[i]); } - TclStackFree(interp, desiredObjs); + ckfree(desiredObjs); return TCL_ERROR; } @@ -1449,7 +1448,7 @@ InitArgsAndLocals( * parameters. */ - varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var))); + varPtr = ckalloc((int)(localCt * sizeof(Var))); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; @@ -1740,9 +1739,9 @@ TclNRInterpProcCore( 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; } @@ -1912,9 +1911,9 @@ InterpProcNR2( 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; } @@ -2516,7 +2515,7 @@ SetLambdaFromAny( */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr = ckalloc(sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; if (contextPtr->type == TCL_LOCATION_BC) { @@ -2580,7 +2579,7 @@ SetLambdaFromAny( Tcl_DecrRefCount(contextPtr->data.eval.path); } - TclStackFree(interp, contextPtr); + ckfree(contextPtr); } /* @@ -2717,7 +2716,7 @@ TclNRApplyObjCmd( 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; @@ -2768,7 +2767,7 @@ ApplyNR2( ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; } - TclStackFree(interp, extraPtr); + ckfree(extraPtr); return result; } diff --git a/generic/tclScan.c b/generic/tclScan.c index c862be4..45f970d 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -259,7 +259,7 @@ ValidateFormat( 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]; /* @@ -465,8 +465,7 @@ ValidateFormat( } 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; } @@ -509,7 +508,7 @@ ValidateFormat( } } - TclStackFree(interp, nassign); + ckfree(nassign); return TCL_OK; badIndex: @@ -523,7 +522,7 @@ ValidateFormat( } error: - TclStackFree(interp, nassign); + ckfree(nassign); return TCL_ERROR; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index eb9a9be..84c1ea9 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -57,7 +57,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 0 */ 0, /* 1 */ 0, /* 2 */ - TclAllocateFreeObjects, /* 3 */ + 0, /* 3 */ 0, /* 4 */ TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ @@ -269,8 +269,8 @@ static const TclIntStubs tclIntStubs = { TclpFindExecutable, /* 212 */ TclGetObjNameOfExecutable, /* 213 */ TclSetObjNameOfExecutable, /* 214 */ - TclStackAlloc, /* 215 */ - TclStackFree, /* 216 */ + 0, /* 215 */ + 0, /* 216 */ TclPushStackFrame, /* 217 */ TclPopStackFrame, /* 218 */ 0, /* 219 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index b757185..2878c8d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6720,7 +6720,7 @@ TestNRELevels( 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; @@ -6734,16 +6734,14 @@ TestNRELevels( 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; } diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c deleted file mode 100755 index c3acb2a..0000000 --- a/generic/tclThreadAlloc.c +++ /dev/null @@ -1,1081 +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; - -/* - *---------------------------------------------------------------------- - * - * 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 - - cachePtr = TclpGetAllocCache(); - if (cachePtr == NULL) { - cachePtr = GetCache(); - } - - /* - * 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; - } - - cachePtr = TclpGetAllocCache(); - if (cachePtr == NULL) { - cachePtr = GetCache(); - } - - /* - * 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 - - cachePtr = TclpGetAllocCache(); - if (cachePtr == NULL) { - cachePtr = GetCache(); - } - - /* - * If the block is not a system block and fits in place, simply return the - * existing pointer. Otherwise, if the block is a system block and the new - * size would also require a system block, call realloc() directly. - */ - - blockPtr = Ptr2Block(ptr); - size = reqSize + sizeof(Block); -#if RCHECK - size++; -#endif - bucket = blockPtr->sourceBucket; - if (bucket != NBUCKETS) { - if (bucket > 0) { - min = bucketInfo[bucket-1].blockSize; - } else { - min = 0; - } - if (size > min && size <= bucketInfo[bucket].blockSize) { - cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; - cachePtr->buckets[bucket].totalAssigned += reqSize; - return Block2Ptr(blockPtr, bucket, reqSize); - } - } else if (size > MAXALLOC) { - cachePtr->totalAssigned -= blockPtr->blockReqSize; - cachePtr->totalAssigned += reqSize; - blockPtr = realloc(blockPtr, size); - if (blockPtr == NULL) { - return NULL; - } - return Block2Ptr(blockPtr, NBUCKETS, reqSize); - } - - /* - * Finally, perform an expensive malloc/copy/free. - */ - - newPtr = TclpAlloc(reqSize); - if (newPtr != NULL) { - if (reqSize > blockPtr->blockReqSize) { - reqSize = blockPtr->blockReqSize; - } - memcpy(newPtr, ptr, reqSize); - TclpFree(ptr); - } - return newPtr; -} - -/* - *---------------------------------------------------------------------- - * - * 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 = TclpGetAllocCache(); - register Tcl_Obj *objPtr; - - if (cachePtr == NULL) { - cachePtr = GetCache(); - } - - /* - * 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.otherValuePtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr; - } - } - } - - /* - * Pop the first object. - */ - - objPtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; - 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 = TclpGetAllocCache(); - - if (cachePtr == NULL) { - cachePtr = GetCache(); - } - - /* - * 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 (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.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; -} - -/* - *---------------------------------------------------------------------- - * - * 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) -{ -#if 0 - if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) { - Tcl_MutexLock(bucketInfo[bucket].lockPtr); - cachePtr->buckets[bucket].numWaits++; - sharedPtr->buckets[bucket].numWaits++; - } -#else - Tcl_MutexLock(bucketInfo[bucket].lockPtr); -#endif - 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: - */ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index d5fb6f6..ffbaa17 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1650,7 +1650,7 @@ CallTraceFunction( * 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'; @@ -1661,7 +1661,7 @@ CallTraceFunction( traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr, iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); - TclStackFree(interp, commandCopy); + ckfree(commandCopy); return traceCode; } @@ -2237,7 +2237,7 @@ StringTraceProc( * 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]); @@ -2252,7 +2252,7 @@ StringTraceProc( data->proc(data->clientData, interp, level, (char *) command, cmdPtr->proc, cmdPtr->clientData, objc, argv); - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); return TCL_OK; } diff --git a/tests/nre.test b/tests/nre.test index 295f02e..17f9a51 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -25,8 +25,8 @@ 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 {} { diff --git a/tests/tailcall.test b/tests/tailcall.test index e9ec188..af496fc 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -24,8 +24,8 @@ testConstraint testnrelevels [llength [info commands testnrelevels]] 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 {} { @@ -66,7 +66,7 @@ test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup 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 { @@ -83,7 +83,7 @@ test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup 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 { @@ -101,7 +101,7 @@ test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup } -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 { @@ -124,7 +124,7 @@ test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup } -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 { @@ -142,7 +142,7 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup } -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 { # @@ -167,7 +167,7 @@ test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels known 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 {}} @@ -188,7 +188,7 @@ test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup } -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 { diff --git a/unix/Makefile.in b/unix/Makefile.in index 20ba896..2b5f867 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -304,7 +304,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.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 @@ -445,7 +445,6 @@ GENERIC_SRCS = \ $(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 \ @@ -1007,11 +1006,8 @@ regerror.o: $(REGHDRS) $(GENERIC_DIR)/regerrs.h $(GENERIC_DIR)/regerror.c tclAppInit.o: $(UNIX_DIR)/tclAppInit.c $(CC) -c $(APP_CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c -# On Unix we want to use the normal malloc/free implementation, so we -# specifically set the USE_TCLALLOC flag. - tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCLALLOC=0 $(GENERIC_DIR)/tclAlloc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c @@ -1286,9 +1282,6 @@ tclTimer.o: $(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 diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index d01624c..f6645fd 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -452,8 +452,8 @@ TclpCreateProcess( * 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]); @@ -524,8 +524,8 @@ TclpCreateProcess( for (i = 0; i < argc; i++) { Tcl_DStringFree(&dsArray[i]); } - TclStackFree(interp, newArgv); - TclStackFree(interp, dsArray); + ckfree(newArgv); + ckfree(dsArray); if (pid == -1) { Tcl_AppendResult(interp, "couldn't fork child process: ", diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 0469d7a..a4db0df 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -676,12 +676,11 @@ TclpInetNtoa( #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; @@ -718,6 +717,7 @@ TclpFreeAllocMutex( free(lockPtr); } + void TclpFreeAllocCache( void *ptr) @@ -760,8 +760,9 @@ TclpSetAllocCache( { pthread_setspecific(key, arg); } -#endif /* USE_THREAD_ALLOC */ +#endif +#ifdef TCL_THREADS void * TclpThreadCreateKey(void) { -- cgit v0.12 From 3504143b6c065a392dd1e98e22e06c53e0fc4e4e Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 13:10:03 +0000 Subject: README addition --- README.mig-alloc-reform | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform index 139af2e..92debc3 100644 --- a/README.mig-alloc-reform +++ b/README.mig-alloc-reform @@ -38,6 +38,10 @@ What is mig-alloc-reform? ** 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 -- cgit v0.12 From 46c7a6bcac3a7466a3bf33ce1aaf81c4f5563afa Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 13:25:23 +0000 Subject: README addition --- README.mig-alloc-reform | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform index 92debc3..5a52c26 100644 --- a/README.mig-alloc-reform +++ b/README.mig-alloc-reform @@ -48,7 +48,7 @@ What is mig-alloc-reform? 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 -- cgit v0.12 From eed4991d081bb530cc04accd03144a4d815d2b3a Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 13:32:33 +0000 Subject: README addition --- README.mig-alloc-reform | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform index 5a52c26..302812a 100644 --- a/README.mig-alloc-reform +++ b/README.mig-alloc-reform @@ -9,8 +9,10 @@ What is mig-alloc-reform? 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 improvement in zippy's memory usage: try to split blocks in - the shared cache before allocating new ones from the system + 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 -- cgit v0.12 From 8fa8bd69eb29f77d7d92d3f3c79385ee28f87ccc Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 16:16:09 +0000 Subject: New function TclAllocMaximize(). Let tclListObj.c find out the real allocated size, thus reducing the number of reallocs. It's good to avoid the interplay between List and Alloc both doubling just-in-case. --- generic/tclAlloc.c | 70 ++++++++++++++++++++++++++++++++++++++++++++-------- generic/tclInt.h | 2 ++ generic/tclListObj.c | 28 ++++++++++++++++----- 3 files changed, 84 insertions(+), 16 deletions(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 782a12b..ff04c2b 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -197,7 +197,6 @@ typedef struct Block { #define magicNum1 u.s.magic1 #define magicNum2 u.s.magic2 #define MAGIC 0xEF -#define blockReqSize reqSize /* * The following defines the minimum and maximum block sizes and the number @@ -385,7 +384,7 @@ Block2Ptr( blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC; blockPtr->sourceBucket = bucket; - blockPtr->blockReqSize = reqSize; + blockPtr->reqSize = reqSize; ptr = (void *) (((char *)blockPtr) + OFFSET); #if RCHECK ((unsigned char *)(ptr))[reqSize] = MAGIC; @@ -405,10 +404,10 @@ Ptr2Block( blockPtr, blockPtr->magicNum1, blockPtr->magicNum2); } #if RCHECK - if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) { + if (((unsigned char *) ptr)[blockPtr->reqSize] != MAGIC) { Tcl_Panic("alloc: invalid block: %p: %x %x %x", blockPtr, blockPtr->magicNum1, blockPtr->magicNum2, - ((unsigned char *) ptr)[blockPtr->blockReqSize]); + ((unsigned char *) ptr)[blockPtr->reqSize]); } #endif return blockPtr; @@ -707,14 +706,14 @@ TclpFree( bucket = blockPtr->sourceBucket; if (bucket == nBuckets) { #ifdef ZIPPY_STATS - cachePtr->totalAssigned -= blockPtr->blockReqSize; + cachePtr->totalAssigned -= blockPtr->reqSize; #endif free(blockPtr); return; } #ifdef ZIPPY_STATS - cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; + cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; #endif blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr; @@ -800,14 +799,14 @@ TclpRealloc( } if (size > min && size <= bucketInfo[bucket].blockSize) { #ifdef ZIPPY_STATS - cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; + cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; cachePtr->buckets[bucket].totalAssigned += reqSize; #endif return Block2Ptr(blockPtr, bucket, reqSize); } } else if (size > MAXALLOC) { #ifdef ZIPPY_STATS - cachePtr->totalAssigned -= blockPtr->blockReqSize; + cachePtr->totalAssigned -= blockPtr->reqSize; cachePtr->totalAssigned += reqSize; #endif blockPtr = realloc(blockPtr, size); @@ -823,14 +822,65 @@ TclpRealloc( newPtr = TclpAlloc(reqSize); if (newPtr != NULL) { - if (reqSize > blockPtr->blockReqSize) { - reqSize = blockPtr->blockReqSize; + if (reqSize > blockPtr->reqSize) { + reqSize = blockPtr->reqSize; } memcpy(newPtr, ptr, reqSize); TclpFree(ptr); } return newPtr; } + +/* + *---------------------------------------------------------------------- + * + * TclAllocMaximize -- + * + * Given a TclpAlloc'ed pointer, it returns the maximal size that can be used + * by the allocated memory. This is almost always larger than the requested + * size, as it corresponds to the bucket's size. + * + * Results: + * New size. + * + *---------------------------------------------------------------------- + */ + unsigned int + TclAllocMaximize( + void *ptr) +{ + Block *blockPtr; + int bucket; + size_t oldSize, newSize; + + if (allocator < aNONE) { + /* + * No info, return UINT_MAX as a signal. + */ + + return UINT_MAX; + } + + blockPtr = Ptr2Block(ptr); + bucket = blockPtr->sourceBucket; + + if (bucket == nBuckets) { + /* + * System malloc'ed: no info + */ + + return UINT_MAX; + } + + oldSize = blockPtr->reqSize; + newSize = bucketInfo[bucket].blockSize - OFFSET - RCHECK; + blockPtr->reqSize = newSize; +#if RCHECK + ((unsigned char *)(ptr))[newSize] = MAGIC; +#endif + return newSize; +} + #ifdef ZIPPY_STATS /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 45eaf7e..1f1e1d3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3864,10 +3864,12 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); # define TclpAlloc(size) ckalloc(size) # define TclpRealloc(ptr, size) ckrealloc((ptr),(size)) # define TclpFree(size) ckfree(size) +# define TclAllocMaximize(ptr) UINT_MAX #else MODULE_SCOPE char * TclpAlloc(unsigned int size); MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size); MODULE_SCOPE void TclpFree(char * ptr); + MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr); #endif #if TCL_ALLOCATOR == aPURIFY diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 46710d6..814acd7 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -67,13 +67,23 @@ const Tcl_ObjType tclListType = { *---------------------------------------------------------------------- */ +#define Elems2Size(n) \ + ((n > 1) \ + ? (sizeof(List) + (n-1)*sizeof(Tcl_Obj *)) \ + : (sizeof(List))) +#define Size2Elems(s) \ + ((s > sizeof(List) + sizeof(Tcl_Obj *) -1) \ + ? (s - sizeof(List) + sizeof(Tcl_Obj *))/sizeof(Tcl_Obj *) \ + : 1) + static List * NewListIntRep( int objc, Tcl_Obj *const objv[]) { List *listRepPtr; - + unsigned int allocSize; + if (objc <= 0) { return NULL; } @@ -89,14 +99,17 @@ NewListIntRep( return NULL; } - listRepPtr = attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj*))); + listRepPtr = attemptckalloc(Elems2Size(objc)); if (listRepPtr == NULL) { return NULL; } - + allocSize = TclAllocMaximize(listRepPtr); + listRepPtr->canonicalFlag = 0; listRepPtr->refCount = 0; - listRepPtr->maxElemCount = objc; + listRepPtr->maxElemCount = (allocSize == UINT_MAX) + ? objc + : Size2Elems(allocSize); if (objv) { Tcl_Obj **elemPtrs; @@ -576,7 +589,7 @@ Tcl_ListObjAppendElement( if (numRequired > listRepPtr->maxElemCount){ newMax = 2 * numRequired; - newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *)); + newSize = Elems2Size(newMax); } else { newMax = listRepPtr->maxElemCount; newSize = 0; @@ -601,7 +614,10 @@ Tcl_ListObjAppendElement( oldListRepPtr->refCount--; } else if (newSize) { listRepPtr = ckrealloc(listRepPtr, newSize); - listRepPtr->maxElemCount = newMax; + newSize = TclAllocMaximize(listRepPtr); + listRepPtr->maxElemCount = (newSize == UINT_MAX) + ? newMax + : Size2Elems(newSize); } listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; -- cgit v0.12 From b1edda8715f1cab75c0f12e7ba71c6e8d5e6e0a7 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 18:06:59 +0000 Subject: remove unused mutex --- generic/tclObj.c | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 5056c1c..5ee957d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -27,16 +27,6 @@ static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) /* - * 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; -#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 * shared by all new objects allocated by Tcl_NewObj. -- cgit v0.12 From 0c6e7852c9f3570adf39a45c72ad1e0b9850b470 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 18:57:35 +0000 Subject: let TEBC also use TclAllocMaximize --- generic/tclExecute.c | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b340144..2ed1537 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1535,6 +1535,12 @@ TclIncrObj( #define catchStack (TD->stack) #define initTosPtr ((Tcl_Obj **) &TD->stack[codePtr->maxExceptDepth - 1]) +#define capacity2size(cap) \ + (sizeof(TEBCdata) + sizeof(void *)*(cap + codePtr->maxExceptDepth - 1)) + +#define size2capacity(s) \ + (((s - sizeof(TEBCdata))/sizeof(void *)) - codePtr->maxExceptDepth + 1) + int TclNRExecuteByteCode( Tcl_Interp *interp, /* Token for command interpreter. */ @@ -1542,8 +1548,7 @@ TclNRExecuteByteCode( { Interp *iPtr = (Interp *) interp; TEBCdata *TD; - unsigned int size = sizeof(TEBCdata) + sizeof(void *) * - (codePtr->maxStackDepth + codePtr->maxExceptDepth - 1); + unsigned int size = capacity2size(codePtr->maxStackDepth); if (iPtr->execEnvPtr->rewind) { return TCL_ERROR; @@ -1564,6 +1569,13 @@ TclNRExecuteByteCode( */ TD = ckalloc(size); + size = TclAllocMaximize(TD); + if (size == UINT_MAX) { + TD->capacity = codePtr->maxStackDepth; + } else { + TD->capacity = size2capacity(size); + } + TD->tosPtr = initTosPtr; TD->codePtr = codePtr; @@ -1572,7 +1584,6 @@ TclNRExecuteByteCode( 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 @@ -2284,13 +2295,17 @@ TEBCresume( (void) POP_OBJECT(); if (reqWords > TD->capacity) { ptrdiff_t depth; - unsigned int size = sizeof(TEBCdata) + sizeof(void *) * - + (reqWords + codePtr->maxExceptDepth - 1); + unsigned int size = capacity2size(reqWords); depth = tosPtr - initTosPtr; TD = ckrealloc(TD, size); + size = TclAllocMaximize(TD); + if (size == UINT_MAX) { + TD->capacity = reqWords; + } else { + TD->capacity = size2capacity(size); + } tosPtr = initTosPtr + depth; - TD->capacity = reqWords; } /* -- cgit v0.12 From 5d469a215fdc4fdb33b70cbd29969293680963e5 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 19:18:36 +0000 Subject: let TclAllocMaximize maintain zippys stats --- generic/tclAlloc.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index ff04c2b..f5fe3ee 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -877,7 +877,14 @@ TclpRealloc( blockPtr->reqSize = newSize; #if RCHECK ((unsigned char *)(ptr))[newSize] = MAGIC; -#endif +#endif +#ifdef ZIPPY_STATS + { + Cache *cachePtr; + GETCACHE(cachePtr); + cachePtr->buckets[bucket].totalAssigned += (newSize - oldSize); + } +#endif return newSize; } -- cgit v0.12 From f8767a126788d49a650721c15333965c47492abd Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 22:42:48 +0000 Subject: move the allocator stuff to the end of tclInt.h, in order not to interfere with tclIntDecls.h --- generic/tclInt.h | 191 ++++++++++++++++++++++++++++--------------------------- 1 file changed, 96 insertions(+), 95 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 1f1e1d3..6bc8f49 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3815,101 +3815,6 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #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 - -/* - * List of valid allocators. Have to respect the following convention: - * - allocators that shunt TclpAlloc to malloc are below aNONE - * - allocators that use zippy are above aNONE - */ - -#define aNATIVE 0 -#define aPURIFY 1 -#define aNONE 2 -#define aZIPPY 3 -#define aMULTI 4 - -#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI)) -#undef TCL_ALLOCATOR -#endif - -#ifdef PURIFY -# undef TCL_ALLOCATOR -# define TCL_ALLOCATOR aPURIFY -#endif - -#if !defined(TCL_ALLOCATOR) -# if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC) -# define TCL_ALLOCATOR aZIPPY -# else -# define TCL_ALLOCATOR aNATIVE -# endif -#endif - -#if TCL_ALLOCATOR < aNONE /* native or purify */ -# define TclpAlloc(size) ckalloc(size) -# define TclpRealloc(ptr, size) ckrealloc((ptr),(size)) -# define TclpFree(size) ckfree(size) -# define TclAllocMaximize(ptr) UINT_MAX -#else - MODULE_SCOPE char * TclpAlloc(unsigned int size); - MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size); - MODULE_SCOPE void TclpFree(char * ptr); - MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr); -#endif - -#if TCL_ALLOCATOR == aPURIFY -# define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj)) -# define TclSmallFree(ptr) ckfree(ptr) -# define TclInitAlloc() -# define TclFinalizeAlloc() -#else - MODULE_SCOPE void * TclSmallAlloc(); - MODULE_SCOPE void TclSmallFree(void *ptr); - MODULE_SCOPE void TclInitAlloc(void); - MODULE_SCOPE void TclFinalizeAlloc(void); -#endif - -#define TclCkSmallAlloc(nbytes, memPtr) \ - do { \ - TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - memPtr = TclSmallAlloc(); \ - } while (0) - -/* - * Support for Clang Static Analyzer - */ - -#if (TCL_ALLOCATOR == aPURIFY) && 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 @@ -4506,6 +4411,102 @@ typedef struct NRE_callback { #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" +/* + * Macros that drive the allocator behaviour + * WARNING: these have to come AFTER tclIntDecls.h, as some macros may + * interfere with those declarations. + */ + +#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 + +/* + * List of valid allocators. Have to respect the following convention: + * - allocators that shunt TclpAlloc to malloc are below aNONE + * - allocators that use zippy are above aNONE + */ + +#define aNATIVE 0 +#define aPURIFY 1 +#define aNONE 2 +#define aZIPPY 3 +#define aMULTI 4 + +#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI)) +#undef TCL_ALLOCATOR +#endif + +#ifdef PURIFY +# undef TCL_ALLOCATOR +# define TCL_ALLOCATOR aPURIFY +#endif + +#if !defined(TCL_ALLOCATOR) +# if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC) +# define TCL_ALLOCATOR aZIPPY +# else +# define TCL_ALLOCATOR aNATIVE +# endif +#endif + +#if TCL_ALLOCATOR < aNONE /* native or purify */ +# define TclpAlloc(size) ckalloc(size) +# define TclpRealloc(ptr, size) ckrealloc((ptr),(size)) +# define TclpFree(size) ckfree(size) +# define TclAllocMaximize(ptr) UINT_MAX +#else + MODULE_SCOPE char * TclpAlloc(unsigned int size); + MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size); + MODULE_SCOPE void TclpFree(char * ptr); + MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr); +#endif + +#if TCL_ALLOCATOR == aPURIFY +# define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj)) +# define TclSmallFree(ptr) ckfree(ptr) +# define TclInitAlloc() +# define TclFinalizeAlloc() +#else + MODULE_SCOPE void * TclSmallAlloc(); + MODULE_SCOPE void TclSmallFree(void *ptr); + MODULE_SCOPE void TclInitAlloc(void); + MODULE_SCOPE void TclFinalizeAlloc(void); +#endif + +#define TclCkSmallAlloc(nbytes, memPtr) \ + do { \ + TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ + memPtr = TclSmallAlloc(); \ + } while (0) + +/* + * Support for Clang Static Analyzer + */ + +#if (TCL_ALLOCATOR == aPURIFY) && 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__ */ + + #endif /* _TCLINT */ /* -- cgit v0.12 From edd8ea9b6b9bc1370a799e86323a6ecc3618668d Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 22:57:06 +0000 Subject: remove TclpAlloc and friends from internal stubs --- generic/tclInt.decls | 18 ++--- generic/tclInt.h | 191 +++++++++++++++++++++++++------------------------- generic/tclIntDecls.h | 24 +++---- generic/tclStubInit.c | 6 +- 4 files changed, 116 insertions(+), 123 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 6330836..75cb20a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -290,9 +290,9 @@ declare 64 { #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) #} @@ -306,9 +306,9 @@ declare 69 { #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) } @@ -332,9 +332,9 @@ declare 78 { # 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) diff --git a/generic/tclInt.h b/generic/tclInt.h index 6bc8f49..1f1e1d3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3815,6 +3815,101 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #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 + +/* + * List of valid allocators. Have to respect the following convention: + * - allocators that shunt TclpAlloc to malloc are below aNONE + * - allocators that use zippy are above aNONE + */ + +#define aNATIVE 0 +#define aPURIFY 1 +#define aNONE 2 +#define aZIPPY 3 +#define aMULTI 4 + +#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI)) +#undef TCL_ALLOCATOR +#endif + +#ifdef PURIFY +# undef TCL_ALLOCATOR +# define TCL_ALLOCATOR aPURIFY +#endif + +#if !defined(TCL_ALLOCATOR) +# if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC) +# define TCL_ALLOCATOR aZIPPY +# else +# define TCL_ALLOCATOR aNATIVE +# endif +#endif + +#if TCL_ALLOCATOR < aNONE /* native or purify */ +# define TclpAlloc(size) ckalloc(size) +# define TclpRealloc(ptr, size) ckrealloc((ptr),(size)) +# define TclpFree(size) ckfree(size) +# define TclAllocMaximize(ptr) UINT_MAX +#else + MODULE_SCOPE char * TclpAlloc(unsigned int size); + MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size); + MODULE_SCOPE void TclpFree(char * ptr); + MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr); +#endif + +#if TCL_ALLOCATOR == aPURIFY +# define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj)) +# define TclSmallFree(ptr) ckfree(ptr) +# define TclInitAlloc() +# define TclFinalizeAlloc() +#else + MODULE_SCOPE void * TclSmallAlloc(); + MODULE_SCOPE void TclSmallFree(void *ptr); + MODULE_SCOPE void TclInitAlloc(void); + MODULE_SCOPE void TclFinalizeAlloc(void); +#endif + +#define TclCkSmallAlloc(nbytes, memPtr) \ + do { \ + TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ + memPtr = TclSmallAlloc(); \ + } while (0) + +/* + * Support for Clang Static Analyzer + */ + +#if (TCL_ALLOCATOR == aPURIFY) && 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 @@ -4411,102 +4506,6 @@ typedef struct NRE_callback { #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" -/* - * Macros that drive the allocator behaviour - * WARNING: these have to come AFTER tclIntDecls.h, as some macros may - * interfere with those declarations. - */ - -#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 - -/* - * List of valid allocators. Have to respect the following convention: - * - allocators that shunt TclpAlloc to malloc are below aNONE - * - allocators that use zippy are above aNONE - */ - -#define aNATIVE 0 -#define aPURIFY 1 -#define aNONE 2 -#define aZIPPY 3 -#define aMULTI 4 - -#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI)) -#undef TCL_ALLOCATOR -#endif - -#ifdef PURIFY -# undef TCL_ALLOCATOR -# define TCL_ALLOCATOR aPURIFY -#endif - -#if !defined(TCL_ALLOCATOR) -# if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC) -# define TCL_ALLOCATOR aZIPPY -# else -# define TCL_ALLOCATOR aNATIVE -# endif -#endif - -#if TCL_ALLOCATOR < aNONE /* native or purify */ -# define TclpAlloc(size) ckalloc(size) -# define TclpRealloc(ptr, size) ckrealloc((ptr),(size)) -# define TclpFree(size) ckfree(size) -# define TclAllocMaximize(ptr) UINT_MAX -#else - MODULE_SCOPE char * TclpAlloc(unsigned int size); - MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size); - MODULE_SCOPE void TclpFree(char * ptr); - MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr); -#endif - -#if TCL_ALLOCATOR == aPURIFY -# define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj)) -# define TclSmallFree(ptr) ckfree(ptr) -# define TclInitAlloc() -# define TclFinalizeAlloc() -#else - MODULE_SCOPE void * TclSmallAlloc(); - MODULE_SCOPE void TclSmallFree(void *ptr); - MODULE_SCOPE void TclInitAlloc(void); - MODULE_SCOPE void TclFinalizeAlloc(void); -#endif - -#define TclCkSmallAlloc(nbytes, memPtr) \ - do { \ - TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - memPtr = TclSmallAlloc(); \ - } while (0) - -/* - * Support for Clang Static Analyzer - */ - -#if (TCL_ALLOCATOR == aPURIFY) && 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__ */ - - #endif /* _TCLINT */ /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 0966d32..dce5dae 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -199,14 +199,12 @@ EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc, /* 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 */ @@ -217,8 +215,7 @@ EXTERN void TclpGetTime(Tcl_Time *time); EXTERN int TclpGetTimeZone(unsigned long time); /* 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 */ @@ -672,19 +669,19 @@ typedef struct TclIntStubs { 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 */ int (*tclpGetTimeZone) (unsigned long time); /* 78 */ 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); @@ -977,14 +974,12 @@ extern const TclIntStubs *tclIntStubsPtr; /* 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 \ @@ -995,8 +990,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpGetTimeZone) /* 78 */ /* 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 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 84c1ea9..0583961 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -123,19 +123,19 @@ static const TclIntStubs tclIntStubs = { 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 */ TclpGetTimeZone, /* 78 */ 0, /* 79 */ 0, /* 80 */ - TclpRealloc, /* 81 */ + 0, /* 81 */ 0, /* 82 */ 0, /* 83 */ 0, /* 84 */ -- cgit v0.12 From 4843669df511f30ec9024092dcdd019a5a5792df Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 18 Mar 2011 23:04:03 +0000 Subject: getting aPURIFY to build? --- generic/tclInt.h | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index 1f1e1d3..92c494e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3877,6 +3877,7 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); # define TclSmallFree(ptr) ckfree(ptr) # define TclInitAlloc() # define TclFinalizeAlloc() +# define TclFreeAllocCache(ptr) #else MODULE_SCOPE void * TclSmallAlloc(); MODULE_SCOPE void TclSmallFree(void *ptr); -- cgit v0.12 From c2c2d39a30718bca7a5243506be96f9a59a84322 Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Mar 2011 12:24:43 +0000 Subject: get purify and native to build by removing ref to ckalloc and friends --- generic/tclInt.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 92c494e..a05007f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3861,9 +3861,9 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); #endif #if TCL_ALLOCATOR < aNONE /* native or purify */ -# define TclpAlloc(size) ckalloc(size) -# define TclpRealloc(ptr, size) ckrealloc((ptr),(size)) -# define TclpFree(size) ckfree(size) +# define TclpAlloc(size) malloc(size) +# define TclpRealloc(ptr, size) realloc((ptr),(size)) +# define TclpFree(size) free(size) # define TclAllocMaximize(ptr) UINT_MAX #else MODULE_SCOPE char * TclpAlloc(unsigned int size); -- cgit v0.12 From 7594338af93c41ff22ddc17d9172d97b4a376d6c Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Mar 2011 17:23:05 +0000 Subject: tclListObj.c: simplify macros --- generic/tclListObj.c | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 814acd7..4c1e219 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -67,14 +67,11 @@ const Tcl_ObjType tclListType = { *---------------------------------------------------------------------- */ -#define Elems2Size(n) \ - ((n > 1) \ - ? (sizeof(List) + (n-1)*sizeof(Tcl_Obj *)) \ - : (sizeof(List))) +#define Elems2Size(n) \ + (sizeof(List) - sizeof(Tcl_Obj *) + n*sizeof(Tcl_Obj *)) + #define Size2Elems(s) \ - ((s > sizeof(List) + sizeof(Tcl_Obj *) -1) \ - ? (s - sizeof(List) + sizeof(Tcl_Obj *))/sizeof(Tcl_Obj *) \ - : 1) + (s - (sizeof(List) - sizeof(Tcl_Obj *)))/sizeof(Tcl_Obj *) static List * NewListIntRep( -- cgit v0.12 From ad01c2a5d674e9304c376a1872a4ec39e03972b8 Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Mar 2011 17:56:06 +0000 Subject: look at all blocks in this thread before looking in the shared cache --- generic/tclAlloc.c | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index f5fe3ee..efaf6ac 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -1230,20 +1230,28 @@ GetBlocks( cachePtr->buckets[n].firstPtr = blockPtr->nextBlock; cachePtr->buckets[n].numFree--; break; - } else if (sharedPtr->buckets[n].numFree > 0){ - LockBucket(cachePtr, n); + } + } +#if defined(TCL_THREADS) + if (blockPtr == NULL) { + n = nBuckets; + size = 0; /* lint */ + while (--n > bucket) { if (sharedPtr->buckets[n].numFree > 0) { - blockPtr = sharedPtr->buckets[n].firstPtr; - sharedPtr->buckets[n].firstPtr = blockPtr->nextBlock; - sharedPtr->buckets[n].numFree--; + LockBucket(cachePtr, n); + if (sharedPtr->buckets[n].numFree > 0) { + blockPtr = sharedPtr->buckets[n].firstPtr; + sharedPtr->buckets[n].firstPtr = blockPtr->nextBlock; + sharedPtr->buckets[n].numFree--; + UnlockBucket(cachePtr, n); + break; + } UnlockBucket(cachePtr, n); - break; } - UnlockBucket(cachePtr, n); } } #endif - +#endif /* * Otherwise, allocate a big new block directly. */ -- cgit v0.12 From f91eaa901468a1b6066b1cd8d7bc0b05684f17c3 Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Mar 2011 19:00:19 +0000 Subject: uninited var in last commit --- generic/tclAlloc.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index efaf6ac..f186d67 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -387,6 +387,7 @@ Block2Ptr( blockPtr->reqSize = reqSize; ptr = (void *) (((char *)blockPtr) + OFFSET); #if RCHECK + TclPanic("RCHECK??"); ((unsigned char *)(ptr))[reqSize] = MAGIC; #endif return (char *) ptr; @@ -1224,8 +1225,8 @@ GetBlocks( n = nBuckets; size = 0; /* lint */ while (--n > bucket) { - size = bucketInfo[n].blockSize; 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--; @@ -1238,6 +1239,7 @@ GetBlocks( size = 0; /* lint */ while (--n > bucket) { if (sharedPtr->buckets[n].numFree > 0) { + size = bucketInfo[n].blockSize; LockBucket(cachePtr, n); if (sharedPtr->buckets[n].numFree > 0) { blockPtr = sharedPtr->buckets[n].firstPtr; -- cgit v0.12 From 8acfdb842be3b3b543602a913afd70257c3adbe1 Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Mar 2011 19:35:23 +0000 Subject: remove stray panic set for debugging --- generic/tclAlloc.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index f186d67..85f7036 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -387,7 +387,6 @@ Block2Ptr( blockPtr->reqSize = reqSize; ptr = (void *) (((char *)blockPtr) + OFFSET); #if RCHECK - TclPanic("RCHECK??"); ((unsigned char *)(ptr))[reqSize] = MAGIC; #endif return (char *) ptr; -- cgit v0.12 From f178c1aaf71fda7178990a0b5bf8f7910af7c87e Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Mar 2011 19:44:20 +0000 Subject: early return on freeing a NULL pointer --- generic/tclAlloc.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 85f7036..9c0ab02 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -686,16 +686,16 @@ TclpFree( Block *blockPtr; int bucket; + if (ptr == NULL) { + return; + } + if (allocator < aNONE) { return free((char *) ptr); } GETCACHE(cachePtr); - if (ptr == NULL) { - return; - } - /* * 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 -- cgit v0.12 From 22ed38f5b9c16b297220948b460e412253b807fb Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Mar 2011 21:47:07 +0000 Subject: adding benchmarks on core.tcl.tk; still some weirdos, but looking good --- normBench | 662 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 662 insertions(+) create mode 100644 normBench diff --git a/normBench b/normBench new file mode 100644 index 0000000..e3be695 --- /dev/null +++ b/normBench @@ -0,0 +1,662 @@ +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 +STARTED 2011-03-19 13:34:03 (runbench.tcl v1.30) +Benchmark 1:8.6b1.2 /home/mig/testbench/tclsh/tclsh.trunk +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:20 elapsed +Benchmark 2:8.6b1.2 /home/mig/testbench/tclsh/tclsh.fast +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:18 elapsed +Benchmark 3:8.6b1.2 /home/mig/testbench/tclsh/tclsh.base +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:24 elapsed +Benchmark 4:8.6b1.2 /home/mig/testbench/tclsh/tclsh.multi +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:19 elapsed +Benchmark 5:8.6b1.2 /home/mig/testbench/tclsh/tclsh.purify +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:47 elapsed +Benchmark 6:8.6b1.2 /home/mig/testbench/tclsh/tclsh.native +aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:23 elapsed +R1 R2 R3 R4 R5 +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 +001 ARRAY format genKeys 50 1.00 0.92 1.03 0.93 1.37 1.09 +002 ARRAY format genKeys 500 1.00 0.91 1.01 0.91 1.35 1.08 +003 ARRAY makeHash 500 50 1.00 0.93 0.94 0.92 1.02 0.84 +004 ascii85 strlen 2690 1.00 1.02 1.12 1.01 1.47 1.08 +005 ascii85 strlen 269000 1.00 1.02 1.09 0.98 1.40 1.04 +006 BASE64 decode 10 1.00 0.94 1.00 0.95 1.26 1.07 +007 BASE64 decode 100 1.00 0.94 1.00 0.93 1.23 1.03 +008 BASE64 decode 1000 1.00 0.94 1.01 0.94 1.22 1.02 +009 BASE64 decode 10000 1.00 0.94 0.99 0.95 1.22 1.04 +010 BASE64 decode2 10 1.00 0.96 1.01 0.99 1.29 1.08 +011 BASE64 decode2 100 1.00 0.94 0.99 0.95 1.25 1.03 +012 BASE64 decode2 1000 1.00 0.95 1.00 0.95 1.24 1.03 +013 BASE64 decode2 10000 1.00 0.94 0.99 0.96 1.23 1.03 +014 BASE64 decode3 10 1.00 0.97 1.05 0.99 1.33 1.08 +015 BASE64 decode3 100 1.00 0.99 1.06 1.00 1.31 1.04 +016 BASE64 decode3 1000 1.00 1.00 1.07 1.02 1.32 1.03 +017 BASE64 decode3 10000 1.00 1.00 1.08 1.02 1.29 1.03 +018 BASE64 encode 10 1.00 0.90 1.02 0.94 1.23 1.04 +019 BASE64 encode 100 1.00 0.90 1.02 0.96 1.20 0.99 +020 BASE64 encode 1000 1.00 0.90 1.01 0.96 1.18 1.00 +021 BASE64 encode 10000 1.00 0.90 1.02 0.96 1.19 1.02 +022 BASE64 encode2 10 1.00 0.91 1.02 0.94 1.22 1.02 +023 BASE64 encode2 100 1.00 0.93 1.03 0.97 1.20 0.97 +024 BASE64 encode2 1000 1.00 0.93 1.02 0.97 1.17 0.97 +025 BASE64 encode2 10000 1.00 0.93 1.02 0.96 1.17 0.98 +026 BASE64 encode3 10 1.00 0.96 1.01 0.94 1.24 1.03 +027 BASE64 encode3 100 1.00 1.01 1.03 1.00 1.16 0.98 +028 BASE64 encode3 1000 1.00 1.01 1.03 0.97 1.13 0.94 +029 BASE64 encode3 10000 1.00 1.01 1.03 0.99 1.11 0.95 +030 BIN bitset-v1 1000 chars 1.00 1.10 1.15 1.07 1.54 1.13 +031 BIN bitset-v1 5000 chars 1.00 1.10 1.14 1.07 1.53 1.11 +032 BIN bitset-v1 10000 chars 1.00 1.10 1.13 1.06 1.52 1.10 +033 BIN bitset-v2 1000 chars 1.00 1.06 1.13 1.02 1.48 1.08 +034 BIN bitset-v2 5000 chars 1.00 1.05 1.12 1.02 1.47 1.06 +035 BIN bitset-v2 10000 chars 1.00 1.05 1.13 1.01 1.47 1.07 +036 BIN bitset-v3 1000 chars 1.00 1.01 1.11 0.94 1.33 1.05 +037 BIN bitset-v3 5000 chars 1.00 1.00 1.11 0.94 1.28 1.03 +038 BIN bitset-v3 10000 chars 1.00 1.03 1.10 0.95 1.28 1.04 +039 BIN c scan, 1000b 1.00 0.90 0.98 0.90 1.33 1.16 +040 BIN c scan, 5000b 1.00 0.96 1.01 1.01 1.12 1.05 +041 BIN c scan, 10000b 1.00 0.99 1.03 1.04 1.11 1.11 +042 BIN chars, 10000b 1.00 1.03 1.07 0.96 1.25 1.05 +043 BIN rand string 100b 1.00 1.09 1.19 1.07 1.67 1.10 +044 BIN rand string 5000b 1.00 1.10 1.21 1.08 1.66 1.10 +045 BIN rand2 string 100b 1.00 0.98 1.10 0.99 1.65 1.00 +046 BIN rand2 string 5000b 1.00 0.98 1.11 0.99 1.62 1.00 +047 BIN u char, 10000b 1.00 0.98 1.02 1.00 1.08 1.05 +048 CATCH error, complex 1.00 0.93 1.07 0.93 1.38 1.06 +049 CATCH no catch used 1.00 1.09 1.25 1.10 1.93 1.37 +050 CATCH return error 1.00 0.94 1.06 0.94 1.42 1.10 +051 CATCH return except 1.00 1.12 1.26 1.12 1.88 1.40 +052 CATCH return ok 1.00 1.10 1.29 1.10 1.94 1.33 +053 DATA access in a list 1.00 1.01 1.06 1.06 1.06 1.04 +054 DATA access in an array 1.00 0.97 0.99 1.00 1.09 1.07 +055 DATA create in a list 1.00 0.87 0.96 0.93 1.10 0.90 +056 DATA create in an array 1.00 0.89 0.92 0.88 1.23 1.09 +057 ENC iso2022-jp, gets 1.00 1.03 1.08 1.02 1.21 0.99 +058 ENC iso2022-jp, read 1.00 1.03 1.09 1.02 1.20 1.01 +059 ENC iso2022-jp, read & size 1.00 1.02 1.11 1.02 1.20 1.01 +060 ENC iso8859-2, gets 1.00 0.95 1.02 0.97 1.21 1.07 +061 ENC iso8859-2, read 1.00 0.99 1.03 1.00 1.12 1.08 +062 ENC iso8859-2, read & size 1.00 1.00 1.04 1.01 1.18 1.11 +063 EVAL cmd and mixed lists 1.00 1.03 1.08 1.02 1.51 1.25 +064 EVAL cmd eval as list 1.00 1.00 1.15 1.04 1.93 1.18 +065 EVAL cmd eval as string 1.00 0.98 1.09 1.01 1.55 1.25 +066 EVAL cmd eval in list obj var 1.00 1.07 1.22 1.11 2.07 1.18 +067 EVAL cmd eval in list obj {*} 1.00 1.02 1.14 1.03 1.88 1.16 +068 EVAL list cmd and mixed lists 1.00 1.05 1.11 1.05 1.47 1.25 +069 EVAL list cmd and pure lists 1.00 2.44 2.38 2.45 2.42 1.19 +070 EXPR $a != $b dbl 1.00 1.11 1.27 1.09 2.00 1.47 +071 EXPR $a != $b int 1.00 1.13 1.28 1.13 2.13 1.43 +072 EXPR $a != $b str (!= len) 1.00 1.00 1.14 1.06 1.54 1.14 +073 EXPR $a != $b str (== len) 1.00 0.98 1.12 1.03 1.47 1.11 +074 EXPR $a == $b dbl 1.00 1.09 1.23 1.05 1.91 1.43 +075 EXPR $a == $b int 1.00 1.10 1.25 1.10 2.12 1.44 +076 EXPR $a == $b str (!= len) 1.00 1.00 1.12 1.06 1.56 1.12 +077 EXPR $a == $b str (== len) 1.00 0.96 1.09 1.00 1.43 1.07 +078 EXPR abs as expr 1.00 1.02 1.27 1.00 1.98 1.54 +079 EXPR abs builtin 1.00 1.07 1.30 1.05 2.09 1.46 +080 EXPR braced 1.00 1.09 1.18 1.00 1.65 1.17 +081 EXPR builtin dyn 1.00 0.96 1.00 0.96 1.62 1.26 +082 EXPR builtin sin 1.00 1.06 1.27 1.03 2.08 1.30 +083 EXPR cast double 1.00 1.07 1.35 1.07 2.23 1.32 +084 EXPR cast int 1.00 1.00 1.26 1.04 2.07 1.28 +085 EXPR fifty operands 1.00 1.07 1.12 1.03 1.36 1.15 +086 EXPR incr with expr 1.00 1.14 1.38 1.08 2.32 1.49 +087 EXPR incr with incr 1.00 1.08 1.36 1.06 2.36 1.44 +088 EXPR inline 1.00 1.05 1.16 1.08 1.24 1.03 +089 EXPR one operand 1.00 1.11 1.36 1.14 2.42 1.47 +090 EXPR rand range 1.00 1.03 1.22 1.04 1.99 1.26 +091 EXPR rand range func 1.00 1.06 1.31 1.07 2.14 1.33 +092 EXPR ten operands 1.00 1.09 1.25 1.05 1.85 1.31 +093 EXPR unbraced 1.00 0.97 1.01 0.97 1.57 1.29 +094 EXPR unbraced long 1.00 0.96 1.02 0.93 1.33 1.14 +095 EXPR UpdStrOfDbl+1.23 prec0 1.00 0.99 1.16 1.00 1.68 1.28 +096 EXPR UpdStrOfDbl+1.23 prec12 1.00 1.01 1.22 1.05 1.75 1.28 +097 EXPR UpdStrOfDbl+1.23 prec17 1.00 0.99 1.12 1.01 1.43 1.18 +098 EXPR UpdStrOfDbl+1e-4 prec0 1.00 1.01 1.17 1.01 1.57 1.23 +099 EXPR UpdStrOfDbl+1e-4 prec12 1.00 0.99 1.20 1.06 1.73 1.26 +100 EXPR UpdStrOfDbl+1e-4 prec17 1.00 0.99 1.12 1.02 1.47 1.17 +101 EXPR UpdStrOfDbl+1e27 prec0 1.00 0.96 1.14 0.96 1.51 1.29 +102 EXPR UpdStrOfDbl+1e27 prec12 1.00 0.99 1.25 1.00 1.65 1.37 +103 EXPR UpdStrOfDbl+1e27 prec17 1.00 0.94 1.10 0.93 1.43 1.21 +104 FCOPY binary: 160K 1.00 1.00 0.97 0.99 0.97 1.00 +105 FCOPY encoding: 160K 1.00 0.97 1.03 0.96 0.96 0.93 +106 FCOPY std: 160K 1.00 0.99 0.96 0.98 0.97 0.99 +107 FILE exec interp 1.00 0.96 1.01 0.99 1.08 1.05 +108 FILE exec interp: pkg require 1.00 1.00 1.00 0.99 1.12 1.06 +109 FILE exists tmpfile (obj) 1.00 1.04 1.09 1.07 1.24 1.04 +110 FILE exists ~ 1.00 1.03 1.06 1.03 1.26 1.12 +111 FILE exists! tmpfile (obj) 1.00 1.01 1.09 1.02 1.25 1.02 +112 FILE exists! tmpfile (str) 1.00 0.94 0.97 0.96 1.14 0.99 +113 FILE glob tmpdir (60 entries) 1.00 0.93 1.00 0.97 1.23 1.11 +114 FILE glob / all subcommands 1.00 1.00 1.03 1.00 1.13 1.03 +115 FILE glob / atime 1.00 0.95 0.99 0.96 1.13 1.06 +116 FILE glob / attributes 1.00 1.00 1.01 1.00 1.05 1.03 +117 FILE glob / dirname 1.00 1.00 1.06 0.99 1.44 1.12 +118 FILE glob / executable 1.00 0.95 1.00 0.96 1.13 1.05 +119 FILE glob / exists 1.00 0.95 0.99 0.97 1.14 1.04 +120 FILE glob / extension 1.00 0.99 1.06 0.99 1.42 1.09 +121 FILE glob / isdirectory 1.00 0.93 0.98 0.97 1.13 1.04 +122 FILE glob / isfile 1.00 0.94 0.99 0.96 1.13 1.04 +123 FILE glob / mtime 1.00 0.94 0.99 0.97 1.13 1.05 +124 FILE glob / owned 1.00 0.93 0.97 0.95 1.13 1.04 +125 FILE glob / readable 1.00 0.94 0.98 0.97 1.13 1.04 +126 FILE glob / rootname 1.00 1.02 1.10 0.98 1.43 1.11 +127 FILE glob / size 1.00 0.94 0.98 0.97 1.14 1.04 +128 FILE glob / tail 1.00 1.00 1.07 1.00 1.43 1.11 +129 FILE glob / writable 1.00 0.95 0.99 0.95 1.14 1.04 +130 FILE recurse / -dir 1.00 0.95 1.01 0.97 1.24 1.09 +131 FILE recurse / cd 1.00 0.94 1.00 0.97 1.23 1.06 +132 FORMAT gen 1.00 0.93 1.04 0.93 1.66 1.19 +133 GCCont_cpb::cGCC 50 1.00 0.93 1.01 0.95 1.20 0.98 +134 GCCont_cpb::cGCC 500 1.00 0.93 0.99 0.93 1.16 0.91 +135 GCCont_cpb::cGCC 5000 1.00 0.95 1.00 0.94 1.15 0.93 +136 GCCont_cpbre1::cGCC 50 1.00 0.97 1.02 0.98 1.13 1.01 +137 GCCont_cpbre1::cGCC 500 1.00 0.97 1.01 0.97 1.02 1.00 +138 GCCont_cpbre1::cGCC 5000 1.00 0.97 1.01 0.97 1.01 0.99 +139 GCCont_cpbre2::cGCC 50 1.00 0.97 1.02 0.97 1.09 1.01 +140 GCCont_cpbre2::cGCC 500 1.00 0.97 1.02 0.98 1.02 1.00 +141 GCCont_cpbre2::cGCC 5000 1.00 0.97 1.02 0.98 1.02 1.01 +142 GCCont_cpbrs2::cGCC 50 1.00 0.96 1.07 1.01 1.33 1.07 +143 GCCont_cpbrs2::cGCC 500 1.00 1.01 1.02 1.03 1.17 1.06 +144 GCCont_cpbrs2::cGCC 5000 1.00 0.99 1.01 1.04 1.09 1.02 +145 GCCont_cpbrs::cGCC1 50 1.00 0.94 0.97 0.99 1.28 0.99 +146 GCCont_cpbrs::cGCC1 500 1.00 0.99 0.99 1.01 1.14 1.01 +147 GCCont_cpbrs::cGCC1 5000 1.00 0.99 1.00 1.02 1.02 0.99 +148 GCCont_cpbrs::cGCC2 50 1.00 0.92 0.96 0.96 1.29 0.98 +149 GCCont_cpbrs::cGCC2 500 1.00 0.98 0.99 1.01 1.17 1.01 +150 GCCont_cpbrs::cGCC2 5000 1.00 1.00 1.00 1.02 1.05 0.99 +151 GCCont_cpbrs_trap::cGCC 50 1.00 0.96 1.01 0.97 1.09 1.00 +152 GCCont_cpbrs_trap::cGCC 500 1.00 0.97 1.01 0.98 1.03 1.00 +153 GCCont_cpbrs_trap::cGCC 5000 1.00 0.96 1.02 0.98 1.02 1.00 +154 GCCont_expr::cGCC 50 1.00 0.97 1.04 0.97 1.38 1.15 +155 GCCont_expr::cGCC 500 1.00 0.98 1.04 0.99 1.29 1.11 +156 GCCont_expr::cGCC 5000 1.00 0.95 1.00 0.94 1.32 1.07 +157 GCCont_i::cGCC1 50 1.00 0.96 1.02 0.96 1.16 1.02 +158 GCCont_i::cGCC1 500 1.00 1.00 1.03 0.99 1.13 0.98 +159 GCCont_i::cGCC1 5000 1.00 0.99 1.03 0.98 1.12 0.99 +160 GCCont_i::cGCC2 50 1.00 0.99 1.04 0.98 1.21 1.01 +161 GCCont_i::cGCC2 500 1.00 1.00 1.03 0.99 1.17 0.95 +162 GCCont_i::cGCC2 5000 1.00 1.02 1.05 0.99 1.14 0.97 +163 GCCont_i::cGCC3 50 1.00 0.95 1.04 0.98 1.26 1.04 +164 GCCont_i::cGCC3 500 1.00 0.96 1.03 1.00 1.18 0.98 +165 GCCont_i::cGCC3 5000 1.00 0.97 1.03 0.99 1.18 0.99 +166 GCCont_r1::cGCC 50 1.00 1.01 1.06 0.96 1.22 1.02 +167 GCCont_r1::cGCC 500 1.00 0.99 1.01 0.96 1.15 0.98 +168 GCCont_r1::cGCC 5000 1.00 1.02 1.03 0.94 1.15 0.99 +169 GCCont_r2::cGCC 50 1.00 0.97 1.01 0.96 1.23 1.01 +170 GCCont_r2::cGCC 500 1.00 0.99 1.02 1.00 1.17 0.96 +171 GCCont_r2::cGCC 5000 1.00 0.99 1.02 0.97 1.18 1.00 +172 GCCont_r3::cGCC 50 1.00 0.98 1.04 0.98 1.24 1.03 +173 GCCont_r3::cGCC 500 1.00 0.98 1.03 0.98 1.19 0.97 +174 GCCont_r3::cGCC 5000 1.00 0.98 1.01 0.95 1.18 0.99 +175 GCCont_rsf1::cGCC 50 1.00 0.96 1.04 0.99 1.19 1.02 +176 GCCont_rsf1::cGCC 500 1.00 0.97 1.03 1.00 1.14 0.99 +177 GCCont_rsf1::cGCC 5000 1.00 0.99 1.04 1.00 1.13 1.00 +178 GCCont_rsf2::cGCC1 50 1.00 0.98 1.05 0.99 1.23 1.05 +179 GCCont_rsf2::cGCC1 500 1.00 0.98 1.03 1.00 1.16 1.01 +180 GCCont_rsf2::cGCC1 5000 1.00 0.97 1.03 1.01 1.12 1.00 +181 GCCont_rsf2::cGCC2 50 1.00 0.96 1.04 0.99 1.26 1.06 +182 GCCont_rsf2::cGCC2 500 1.00 0.96 1.02 0.98 1.15 1.00 +183 GCCont_rsf2::cGCC2 5000 1.00 0.96 1.01 0.99 1.13 0.99 +184 GCCont_rsf3::cGCC 50 1.00 0.98 1.05 1.00 1.27 1.05 +185 GCCont_rsf3::cGCC 500 1.00 0.96 1.03 1.00 1.18 1.01 +186 GCCont_rsf3::cGCC 5000 1.00 0.96 1.02 0.98 1.11 1.00 +187 GCCont_turing::cGCC 50 1.00 1.01 1.06 0.98 1.28 1.13 +188 GCCont_turing::cGCC 500 1.00 1.00 1.02 0.98 1.07 1.01 +189 GCCont_turing::cGCC 5000 1.00 1.01 1.02 1.01 1.04 0.99 +190 HEAPSORT size 10 1.00 0.97 1.02 0.98 1.13 1.05 +191 HEAPSORT size 50 1.00 0.97 1.00 0.96 1.10 1.04 +192 HEAPSORT size 100 1.00 0.97 1.00 0.98 1.12 1.05 +193 HEAPSORT2 size 10 1.00 1.04 1.04 1.01 1.11 0.99 +194 HEAPSORT2 size 50 1.00 1.04 1.03 1.02 1.08 1.00 +195 HEAPSORT2 size 100 1.00 1.03 1.03 1.02 1.08 0.99 +196 IF 1/0 check 1.00 1.05 1.31 1.10 2.14 1.38 +197 IF else true al 1.00 0.99 1.09 1.00 1.51 1.12 +198 IF else true numeric 1.00 1.11 1.24 1.10 1.78 1.33 +199 IF elseif true al 1.00 1.00 1.06 0.98 1.48 1.14 +200 IF elseif true numeric 1.00 1.10 1.22 1.10 1.81 1.40 +201 IF if false al/al 1.00 1.01 1.14 1.00 1.65 1.17 +202 IF if false al/num 1.00 1.01 1.13 1.00 1.65 1.29 +203 IF if false num/num 1.00 1.09 1.26 1.09 2.00 1.44 +204 IF if true al 1.00 1.04 1.13 1.03 1.75 1.25 +205 IF if true al/al 1.00 1.09 1.22 1.06 1.78 1.29 +206 IF if true num/num 1.00 1.11 1.30 1.11 1.94 1.45 +207 IF if true numeric 1.00 1.09 1.23 1.08 1.92 1.42 +208 IF multi 1st true 1.00 1.04 1.18 1.09 1.82 1.34 +209 IF multi 2nd true 1.00 1.03 1.18 1.08 1.75 1.31 +210 IF multi 9th true 1.00 1.07 1.16 1.07 1.49 1.20 +211 IF multi default true 1.00 1.06 1.15 1.05 1.53 1.21 +212 KLIST shuffle0 llength 1 1.00 0.94 1.01 0.96 1.41 1.03 +213 KLIST shuffle0 llength 10 1.00 0.95 1.01 0.95 1.30 1.01 +214 KLIST shuffle0 llength 100 1.00 0.99 1.06 0.97 1.26 1.01 +215 KLIST shuffle0 llength 1000 1.00 0.98 1.04 0.97 1.27 1.00 +216 KLIST shuffle0 llength 10000 1.00 0.99 1.02 0.95 1.22 0.98 +217 KLIST shuffle1-s llength 1 1.00 1.00 1.12 1.01 1.70 1.16 +218 KLIST shuffle1-s llength 10 1.00 1.00 1.13 1.00 1.61 1.16 +219 KLIST shuffle1-s llength 100 1.00 0.98 1.10 0.99 1.64 1.22 +220 KLIST shuffle1-s llength 1000 1.00 1.34 1.39 1.35 1.85 1.37 +221 KLIST shuffle1a llength 1 1.00 1.05 1.16 1.03 1.77 1.23 +222 KLIST shuffle1a llength 10 1.00 1.05 1.18 1.05 1.79 1.27 +223 KLIST shuffle1a llength 100 1.00 1.06 1.18 1.06 1.80 1.25 +224 KLIST shuffle1a llength 1000 1.00 1.05 1.18 1.05 1.80 1.26 +225 KLIST shuffle1a llength 10000 1.00 1.06 1.18 1.06 1.81 1.29 +226 KLIST shuffle2 llength 1 1.00 0.98 1.10 1.03 1.51 1.20 +227 KLIST shuffle2 llength 10 1.00 1.00 1.11 1.01 1.44 1.16 +228 KLIST shuffle2 llength 100 1.00 0.99 1.09 1.01 1.41 1.16 +229 KLIST shuffle2 llength 1000 1.00 1.01 1.10 1.02 1.40 1.16 +230 KLIST shuffle2 llength 10000 1.00 0.99 1.06 1.00 1.26 1.04 +231 KLIST shuffle3 llength 1 1.00 1.01 1.16 1.02 1.76 1.24 +232 KLIST shuffle3 llength 10 1.00 1.05 1.19 1.05 1.75 1.24 +233 KLIST shuffle3 llength 100 1.00 1.05 1.19 1.05 1.79 1.23 +234 KLIST shuffle3 llength 1000 1.00 1.05 1.16 1.04 1.70 1.22 +235 KLIST shuffle3 llength 10000 1.00 1.02 1.09 1.03 1.39 1.15 +236 KLIST shuffle4 llength 1 1.00 1.01 1.15 1.04 1.71 1.23 +237 KLIST shuffle4 llength 10 1.00 1.03 1.16 1.03 1.71 1.22 +238 KLIST shuffle4 llength 100 1.00 1.03 1.16 1.03 1.74 1.23 +239 KLIST shuffle4 llength 1000 1.00 1.05 1.17 1.04 1.74 1.23 +240 KLIST shuffle4 llength 10000 1.00 1.04 1.17 1.03 1.74 1.22 +241 KLIST shuffle5-s llength 1 1.00 0.99 1.11 1.01 1.70 1.15 +242 KLIST shuffle5-s llength 10 1.00 1.00 1.12 1.02 1.65 1.18 +243 KLIST shuffle5-s llength 100 1.00 1.00 1.10 1.01 1.66 1.19 +244 KLIST shuffle5-s llength 1000 1.00 1.05 1.10 1.05 1.55 1.20 +245 KLIST shuffle5a llength 1 1.00 1.01 1.14 1.01 1.77 1.19 +246 KLIST shuffle5a llength 10 1.00 1.04 1.18 1.06 1.79 1.24 +247 KLIST shuffle5a llength 100 1.00 1.05 1.18 1.06 1.80 1.27 +248 KLIST shuffle5a llength 1000 1.00 1.02 1.16 1.04 1.73 1.24 +249 KLIST shuffle5a llength 10000 1.00 1.04 1.09 1.04 1.43 1.12 +250 KLIST shuffle6 llength 1 1.00 1.02 1.24 1.15 1.93 1.39 +251 KLIST shuffle6 llength 10 1.00 1.00 1.06 0.99 1.41 1.04 +252 KLIST shuffle6 llength 100 1.00 1.02 1.05 1.01 1.41 1.04 +253 KLIST shuffle6 llength 1000 1.00 1.02 1.08 1.02 1.40 1.04 +254 KLIST shuffle6 llength 10000 1.00 1.05 1.09 1.03 1.43 1.05 +255 LIST append to list 1.00 1.00 1.24 0.98 2.06 1.38 +256 LIST concat APPEND 2x10 1.00 0.88 0.99 0.89 1.47 1.14 +257 LIST concat APPEND 2x100 1.00 0.89 0.98 0.88 1.79 1.25 +258 LIST concat APPEND 2x1000 1.00 0.91 1.00 0.91 1.65 1.20 +259 LIST concat APPEND 2x10000 1.00 0.95 1.04 0.95 1.67 1.20 +260 LIST concat CONCAT 2x10 1.00 1.00 1.13 1.05 1.63 1.20 +261 LIST concat CONCAT 2x100 1.00 1.01 1.09 1.03 1.57 1.19 +262 LIST concat CONCAT 2x1000 1.00 0.98 1.01 0.99 1.10 1.03 +263 LIST concat CONCAT 2x10000 1.00 1.02 0.94 1.02 1.01 1.06 +264 LIST concat EVAL/LAPPEND 2x10 1.00 1.03 1.18 1.06 1.68 1.22 +265 LIST concat EVAL/LAPPEND 2x100 1.00 1.00 1.09 1.01 1.61 1.19 +266 LIST concat EVAL/LAPPEND 2x1000 1.00 0.88 0.90 0.90 0.99 0.94 +267 LIST concat EVAL/LAPPEND 2x10000 1.00 0.94 0.96 0.94 0.95 1.01 +268 LIST concat FOREACH/LAPPEND 2x10 1.00 0.99 1.09 0.99 1.35 1.12 +269 LIST concat FOREACH/LAPPEND 2x100 1.00 1.01 1.08 0.97 1.17 1.07 +270 LIST concat FOREACH/LAPPEND 2x1000 1.00 1.05 1.09 0.98 1.13 1.03 +271 LIST concat FOREACH/LAPPEND 2x10000 1.00 1.05 1.06 0.96 1.11 1.05 +272 LIST concat SET 2x10 1.00 0.89 1.00 0.89 1.48 1.19 +273 LIST concat SET 2x100 1.00 0.90 1.02 0.90 1.84 1.31 +274 LIST concat SET 2x1000 1.00 0.90 0.99 0.89 1.69 1.22 +275 LIST concat SET 2x10000 1.00 0.95 1.04 0.95 1.71 1.23 +276 LIST exact search, first item 1.00 1.09 1.20 1.11 1.92 1.23 +277 LIST exact search, last item 1.00 0.99 1.04 1.01 1.28 1.06 +278 LIST exact search, middle item 1.00 1.02 1.10 1.05 1.60 1.15 +279 LIST exact search, non-item 1.00 1.02 1.02 1.04 1.13 1.04 +280 LIST exact search, typed item 1.00 1.00 1.05 1.03 1.33 1.05 +281 LIST exact search, untyped item 1.00 1.00 1.05 1.00 1.30 1.08 +282 LIST index first element 1.00 1.00 1.20 1.04 1.86 1.33 +283 LIST index last element 1.00 1.00 1.20 1.04 1.92 1.24 +284 LIST index middle element 1.00 0.98 1.20 1.02 1.88 1.27 +285 LIST insert an item at "end" 1.00 1.64 1.70 1.61 1.90 1.11 +286 LIST insert an item at middle 1.00 1.63 1.69 1.60 1.87 1.12 +287 LIST insert an item at start 1.00 1.69 1.75 1.65 1.97 1.16 +288 LIST iterate list 1.00 1.00 1.03 0.99 1.16 0.89 +289 LIST join list 1.00 0.99 1.00 0.99 1.01 1.01 +290 LIST large, early range 1.00 0.95 1.09 0.99 1.67 1.19 +291 LIST large, late range 1.00 1.00 1.12 1.01 1.66 1.20 +292 LIST length, pure list 1.00 0.96 1.19 1.04 1.88 1.40 +293 LIST list 1.00 0.98 1.04 0.97 1.35 1.06 +294 LIST lset foreach l 1.00 0.81 0.84 0.90 1.33 1.13 +295 LIST lset foreach list 1.00 0.88 0.87 0.90 1.37 1.14 +296 LIST lset foreach ""s l 1.00 1.03 1.04 0.98 1.16 1.01 +297 LIST lset foreach ""s list 1.00 1.04 1.06 1.00 1.17 1.00 +298 LIST regexp search, first item 1.00 1.06 1.19 1.12 1.87 1.20 +299 LIST regexp search, last item 1.00 1.00 1.01 1.01 1.05 1.01 +300 LIST regexp search, non-item 1.00 1.04 1.01 1.03 1.05 1.02 +301 LIST remove first element 1.00 1.64 1.71 1.61 2.06 1.15 +302 LIST remove in mixed list 1.00 1.44 1.44 1.48 2.00 1.08 +303 LIST remove last element 1.00 1.68 1.73 1.64 2.10 1.15 +304 LIST remove middle element 1.00 1.64 1.69 1.60 2.05 1.13 +305 LIST replace first el with multiple 1.00 1.74 1.69 1.58 2.02 1.15 +306 LIST replace first element 1.00 1.69 1.72 1.65 2.03 1.13 +307 LIST replace in mixed list 1.00 1.47 1.48 1.49 2.01 0.99 +308 LIST replace last el with multiple 1.00 1.76 1.70 1.56 2.13 1.15 +309 LIST replace last element 1.00 1.73 1.71 1.56 2.09 1.13 +310 LIST replace middle el with multiple 1.00 1.69 1.67 1.54 2.01 1.13 +311 LIST replace middle element 1.00 1.74 1.76 1.69 2.09 1.14 +312 LIST replace range 1.00 0.98 1.06 0.97 1.56 1.24 +313 LIST reverse core 1.00 1.27 1.33 1.19 1.41 1.06 +314 LIST reverse lappend 1.00 1.08 1.13 1.05 1.04 1.09 +315 LIST small, early range 1.00 1.00 1.17 1.03 1.72 1.26 +316 LIST small, late range 1.00 0.99 1.17 1.03 1.72 1.19 +317 LIST sort 1.00 1.07 1.07 1.07 1.08 1.01 +318 LIST sorted search, first item 1.00 0.99 1.13 1.06 1.71 1.25 +319 LIST sorted search, last item 1.00 0.99 1.13 1.03 1.74 1.17 +320 LIST sorted search, middle item 1.00 1.01 1.13 1.04 1.75 1.18 +321 LIST sorted search, non-item 1.00 1.03 1.15 1.07 1.77 1.21 +322 LIST sorted search, typed item 1.00 1.03 1.21 1.13 1.82 1.19 +323 LIST typed sort 1.00 1.08 1.07 1.07 1.08 1.06 +324 LOOP for (to 1000) 1.00 1.03 1.04 1.13 1.05 1.04 +325 LOOP for, iterate list 1.00 0.99 1.07 1.12 1.06 1.08 +326 LOOP for, iterate string 1.00 0.94 1.01 0.97 1.25 1.03 +327 LOOP foreach, iterate list 1.00 0.94 0.98 0.95 1.14 0.92 +328 LOOP foreach, iterate string 1.00 0.96 1.04 0.98 1.19 1.02 +329 LOOP while (to 1000) 1.00 1.07 1.05 1.15 1.08 1.05 +330 LOOP while 1 (to 1000) 1.00 0.98 1.00 1.03 0.91 0.90 +331 MAP ([chars])-case regsub 1.00 0.96 1.00 0.96 1.06 1.01 +332 MAP http mapReply 1.00 0.98 0.98 0.97 1.02 1.00 +333 MAP regsub -nocase, no match 1.00 1.03 1.00 1.01 1.02 1.00 +334 MAP regsub 1 val 1.00 1.00 1.02 1.04 0.98 0.95 +335 MAP regsub 1 val -nocase 1.00 1.02 1.03 1.01 0.99 0.98 +336 MAP regsub 2 val 1.00 1.04 1.08 1.08 1.04 0.97 +337 MAP regsub 2 val -nocase 1.00 1.03 1.04 1.02 1.00 0.99 +338 MAP regsub 3 val 1.00 1.05 1.07 1.07 1.06 0.98 +339 MAP regsub 3 val -nocase 1.00 1.03 1.04 1.03 1.00 0.98 +340 MAP regsub 4 val 1.00 1.02 1.04 1.04 1.06 0.97 +341 MAP regsub 4 val -nocase 1.00 1.02 1.02 1.03 1.02 0.99 +342 MAP regsub short 1.00 1.00 1.07 1.03 1.53 1.24 +343 MAP regsub, no match 1.00 1.02 1.02 1.01 1.05 1.03 +344 MAP string -nocase, no match 1.00 1.02 1.05 1.00 1.05 1.02 +345 MAP string 1 val 1.00 0.99 1.00 1.00 0.98 0.93 +346 MAP string 1 val -nocase 1.00 1.02 1.01 1.02 1.03 1.01 +347 MAP string 2 val 1.00 1.01 1.14 1.03 1.03 0.99 +348 MAP string 2 val -nocase 1.00 0.93 0.95 0.92 1.00 0.92 +349 MAP string 3 val 1.00 1.01 1.02 1.04 1.04 0.98 +350 MAP string 3 val -nocase 1.00 0.97 0.97 0.95 1.02 0.97 +351 MAP string 4 val 1.00 1.00 1.03 1.07 1.07 0.96 +352 MAP string 4 val -nocase 1.00 0.96 0.97 0.97 1.03 0.96 +353 MAP string short 1.00 1.01 1.15 1.02 1.60 1.21 +354 MAP string, no match 1.00 1.00 1.03 1.00 1.02 1.00 +355 MAP |-case regsub 1.00 0.94 1.03 0.95 1.08 1.02 +356 MAP |-case strmap 1.00 1.02 1.20 1.04 1.65 1.29 +357 MATRIX mult 5x5 1.00 0.94 0.98 0.90 1.26 0.99 +358 MATRIX mult 10x10 1.00 0.95 1.00 0.91 1.29 0.99 +359 MATRIX mult 15x15 1.00 0.95 1.00 0.91 1.31 0.98 +360 MATRIX transposition-0 1.00 0.96 0.96 0.95 1.10 1.06 +361 MATRIX transposition-1 1.00 1.00 1.06 0.98 1.06 1.05 +362 MD5 msg len 10 1.00 0.98 1.07 0.99 1.64 1.11 +363 MD5 msg len 100 1.00 0.99 1.08 0.99 1.66 1.11 +364 MD5 msg len 1000 1.00 0.98 1.07 0.98 1.62 1.15 +365 MD5 msg len 10000 1.00 0.91 1.02 0.90 1.41 1.20 +366 MTHD array stored proc call 1.00 1.04 1.23 1.09 2.00 1.39 +367 MTHD call absolute 1.00 1.10 1.38 1.09 2.30 1.44 +368 MTHD call relative 1.00 1.06 1.33 1.06 2.08 1.35 +369 MTHD direct ns proc call 1.00 1.14 1.36 1.11 2.42 1.44 +370 MTHD imported ns proc call 1.00 1.07 1.33 1.07 2.45 1.45 +371 MTHD indirect proc eval 1.00 1.03 1.23 1.03 2.05 1.26 +372 MTHD indirect proc eval #2 1.00 1.10 1.31 1.09 2.19 1.33 +373 MTHD inline call 1.00 1.12 1.19 1.06 1.69 1.25 +374 MTHD interp alias proc call 1.00 1.13 1.34 1.20 2.28 1.44 +375 MTHD ns lookup call 1.00 0.95 1.08 0.96 1.54 1.08 +376 MTHD switch method call 1.00 1.04 1.22 1.03 1.98 1.23 +377 NS alternating 1.00 0.89 1.08 0.90 1.54 1.19 +378 PARSE html form upload (7978) 1.00 0.97 1.07 1.02 1.37 0.99 +379 PARSE html form upload (993570) 1.00 0.99 1.09 1.04 1.38 1.00 +380 PROC do-nothing, no args 1.00 1.09 1.30 1.09 2.27 1.45 +381 PROC do-nothing, one arg 1.00 1.11 1.34 1.11 2.31 1.49 +382 PROC empty, no args 1.00 1.22 1.33 1.22 2.44 1.44 +383 PROC empty, use args 1.00 1.22 1.33 1.22 2.11 1.44 +384 PROC explicit return 1.00 1.12 1.35 1.12 2.41 1.50 +385 PROC explicit return (2) 1.00 1.15 1.32 1.12 2.35 1.53 +386 PROC explicit return (3) 1.00 1.15 1.35 1.15 2.41 1.50 +387 PROC heavily commented 1.00 1.11 1.31 1.11 2.29 1.60 +388 PROC implicit return 1.00 1.11 1.30 1.08 2.30 1.46 +389 PROC implicit return (2) 1.00 1.14 1.31 1.11 2.37 1.49 +390 PROC implicit return (3) 1.00 1.15 1.35 1.15 2.35 1.62 +391 PROC local links with global 1.00 1.05 1.03 1.00 1.07 1.04 +392 PROC local links with upvar 1.00 1.05 1.03 1.00 1.06 1.04 +393 PROC local links with variable 1.00 1.01 1.04 1.00 1.07 1.02 +394 RE 1-char long-end 1.00 1.00 1.02 1.01 1.08 1.03 +395 RE 1-char long-end catching 1.00 1.00 1.03 1.01 1.10 1.04 +396 RE 1-char long-middle 1.00 1.01 1.04 1.03 1.14 1.04 +397 RE 1-char long-middle catching 1.00 1.00 1.04 1.02 1.15 1.06 +398 RE 1-char long-start 1.00 1.03 1.13 1.09 1.46 1.13 +399 RE 1-char long-start catching 1.00 1.00 1.07 1.03 1.27 1.13 +400 RE 1-char short 1.00 1.03 1.15 1.09 1.48 1.12 +401 RE 1-char short catching 1.00 0.99 1.07 1.02 1.26 1.09 +402 RE basic 1.00 1.03 1.17 1.09 1.49 1.15 +403 RE basic catching 1.00 0.99 1.04 1.01 1.22 1.08 +404 RE c-comment long 1.00 1.00 1.02 1.01 1.11 1.06 +405 RE c-comment long catching 1.00 0.99 1.01 1.00 1.09 1.05 +406 RE c-comment long nomatch 1.00 1.00 1.01 1.00 1.07 1.03 +407 RE c-comment long nomatch catching 1.00 1.00 1.01 1.01 1.08 1.04 +408 RE c-comment long pmatch 1.00 1.00 1.01 1.01 1.06 1.04 +409 RE c-comment long pmatch catching 1.00 1.00 1.01 1.01 1.07 1.04 +410 RE c-comment many *s 1.00 0.99 1.01 1.00 1.06 1.04 +411 RE c-comment many *s catching 1.00 0.99 1.00 0.99 1.04 1.03 +412 RE c-comment nomatch 1.00 0.98 1.10 1.02 1.55 1.30 +413 RE c-comment nomatch catching 1.00 0.97 1.08 1.04 1.53 1.27 +414 RE c-comment simple 1.00 0.97 1.05 0.99 1.31 1.15 +415 RE c-comment simple catching 1.00 0.97 1.01 0.98 1.16 1.09 +416 RE count all matches 1.00 0.99 1.03 1.00 1.10 1.04 +417 RE extract all matches 1.00 0.98 1.02 0.98 1.12 1.04 +418 RE ini file 1.00 1.00 1.00 1.00 1.00 1.00 +419 RE ini file ng 1.00 1.00 1.01 1.00 1.02 1.01 +420 RE literal regexp 1.00 0.95 1.09 0.97 1.24 1.02 +421 RE n-char long-end 1.00 1.00 1.03 1.01 1.08 1.03 +422 RE n-char long-end catching 1.00 0.99 1.02 1.00 1.08 1.02 +423 RE n-char long-middle 1.00 1.00 1.04 1.02 1.13 1.04 +424 RE n-char long-middle catching 1.00 0.99 1.02 1.00 1.11 1.03 +425 RE n-char long-start 1.00 1.01 1.12 1.06 1.42 1.12 +426 RE n-char long-start catching 1.00 0.98 1.04 1.01 1.18 1.04 +427 RE n-char short 1.00 1.02 1.13 1.06 1.43 1.12 +428 RE n-char short catching 1.00 0.99 1.06 1.02 1.21 1.06 +429 RE static anchored match 1.00 1.14 1.33 1.14 2.33 1.47 +430 RE static anchored match dot 1.00 1.13 1.34 1.13 2.32 1.47 +431 RE static anchored nomatch 1.00 1.14 1.36 1.14 2.39 1.50 +432 RE static anchored nomatch dot 1.00 1.14 1.36 1.14 2.39 1.47 +433 RE static l-anchored match 1.00 1.14 1.32 1.14 2.35 1.51 +434 RE static l-anchored nomatch 1.00 1.08 1.30 1.11 2.41 1.46 +435 RE static long match 1.00 1.12 1.12 1.16 1.39 1.15 +436 RE static long nomatch 1.00 1.16 1.08 1.18 1.28 1.11 +437 RE static r-anchored match 1.00 1.10 1.31 1.15 2.23 1.44 +438 RE static r-anchored nomatch 1.00 1.15 1.36 1.15 2.28 1.44 +439 RE static short match 1.00 1.10 1.36 1.10 2.28 1.54 +440 RE static short nomatch 1.00 1.13 1.37 1.13 2.39 1.58 +441 RE var ***= directive match 1.00 1.11 1.13 1.15 1.47 1.15 +442 RE var ***= directive nomatch 1.00 1.11 1.10 1.13 1.49 1.17 +443 RE var . match 1.00 1.02 1.16 1.06 1.75 1.22 +444 RE var [0-9] match 1.00 0.99 1.08 1.03 1.26 1.07 +445 RE var \d match 1.00 1.00 1.08 1.03 1.26 1.07 +446 RE var ^$ nomatch 1.00 1.02 1.16 1.03 1.73 1.23 +447 RE var backtrack case 1.00 1.02 1.08 1.05 1.21 1.07 +448 RE var-based regexp 1.00 0.94 1.08 0.97 1.22 1.02 +449 READ 595K, cat 1.00 0.95 0.98 0.96 1.22 0.98 +450 READ 595K, gets 1.00 0.93 0.95 0.91 1.22 0.97 +451 READ 595K, glob-grep match 1.00 0.95 0.97 0.94 1.20 1.04 +452 READ 595K, glob-grep nomatch 1.00 0.94 0.97 0.94 1.18 1.00 +453 READ 595K, read 1.00 1.00 1.00 1.00 1.00 0.92 +454 READ 595K, read & size 1.00 1.00 1.00 1.00 1.00 0.92 +455 READ 595K, read dyn buf 1.00 1.01 0.98 1.01 1.01 0.93 +456 READ 595K, read small buf 1.00 0.98 0.97 0.98 0.98 1.00 +457 READ 3050b, cat 1.00 0.96 1.03 0.96 1.21 1.00 +458 READ 3050b, gets 1.00 0.94 0.97 0.94 1.23 1.01 +459 READ 3050b, glob-grep match 1.00 0.94 0.97 0.93 1.21 1.04 +460 READ 3050b, glob-grep nomatch 1.00 0.94 0.97 0.95 1.18 1.03 +461 READ 3050b, read 1.00 0.99 0.97 1.00 1.08 1.01 +462 READ 3050b, read & size 1.00 0.99 0.99 1.00 1.11 1.03 +463 READ 3050b, read dyn buf 1.00 0.99 0.98 1.00 1.08 1.02 +464 READ 3050b, read small buf 1.00 0.97 1.00 1.00 0.98 1.01 +465 READ bin 595K, cat 1.00 1.06 1.12 0.96 1.42 1.03 +466 READ bin 595K, gets 1.00 1.04 1.06 0.92 1.36 1.04 +467 READ bin 595K, glob-grep match 1.00 1.10 1.06 0.93 1.34 1.03 +468 READ bin 595K, glob-grep nomatch 1.00 1.18 1.08 0.92 1.36 1.05 +469 READ bin 595K, read 1.00 0.99 0.99 0.99 0.98 0.98 +470 READ bin 595K, read & size 1.00 1.00 1.00 1.00 0.99 0.99 +471 READ bin 595K, read dyn buf 1.00 1.04 1.06 1.05 1.02 1.00 +472 READ bin 595K, read small buf 1.00 1.01 1.00 1.02 1.01 1.03 +473 READ bin 3050b, cat 1.00 1.05 1.08 0.96 1.36 1.06 +474 READ bin 3050b, gets 1.00 1.06 1.09 0.97 1.36 1.10 +475 READ bin 3050b, glob-grep match 1.00 0.99 1.07 0.93 1.33 1.16 +476 READ bin 3050b, glob-grep nomatch 1.00 0.99 1.08 0.94 1.31 1.11 +477 READ bin 3050b, read 1.00 0.98 1.04 0.99 1.24 1.11 +478 READ bin 3050b, read & size 1.00 0.99 1.06 1.00 1.26 1.12 +479 READ bin 3050b, read dyn buf 1.00 0.99 1.03 0.98 1.22 1.11 +480 READ bin 3050b, read small buf 1.00 0.99 0.98 0.99 0.99 1.01 +481 SHA1 msg len 10 1.00 0.97 1.04 1.00 1.28 1.02 +482 SHA1 msg len 100 1.00 0.97 1.04 1.00 1.27 1.01 +483 SHA1 msg len 1000 1.00 0.96 1.05 1.00 1.24 1.00 +484 SHA1 msg len 10000 1.00 0.97 1.04 1.01 1.23 0.99 +485 SPLIT iter, 4000 uchars 1.00 0.97 1.03 0.95 1.17 1.01 +486 SPLIT iter, 4010 chars 1.00 0.95 1.01 0.94 1.15 0.99 +487 SPLIT iter, rand 100 c 1.00 0.89 1.01 0.89 1.32 1.10 +488 SPLIT iter, rand 1000 c 1.00 0.94 1.01 0.93 1.26 1.07 +489 SPLIT iter, rand 10000 c 1.00 0.95 1.02 0.94 1.15 0.99 +490 SPLIT on 'c', 4000 uchars 1.00 0.88 0.99 0.89 1.28 1.03 +491 SPLIT on 'c', 4010 chars 1.00 0.87 0.98 0.88 1.29 0.99 +492 SPLIT on 'cz', 4000 uchars 1.00 0.89 0.98 0.90 1.17 0.99 +493 SPLIT on 'cz', 4010 chars 1.00 0.92 0.99 0.93 1.20 1.01 +494 SPLIT on 'cū', 4000 uchars 1.00 0.91 0.99 0.92 1.22 1.05 +495 SPLIT on 'cū', 4010 chars 1.00 0.91 0.99 0.91 1.21 1.00 +496 SPLIT, 4000 uchars 1.00 0.99 1.03 0.99 1.05 1.00 +497 SPLIT, 4010 chars 1.00 1.00 1.05 1.01 1.02 1.02 +498 SPLIT, rand 100 c 1.00 0.86 0.98 0.86 1.41 1.16 +499 SPLIT, rand 1000 c 1.00 0.93 1.02 0.93 1.50 1.26 +500 SPLIT, rand 10000 c 1.00 0.98 1.02 0.99 1.08 1.04 +501 STR append 1.00 1.00 1.06 1.07 1.25 1.09 +502 STR append (1KB + 1KB) 1.00 1.00 1.05 1.02 1.58 1.29 +503 STR append (1MB + (1b+1K+1b)*100) 1.00 0.98 0.99 0.99 1.02 0.99 +504 STR append (1MB + 1KB) 1.00 0.98 0.98 0.98 0.98 0.98 +505 STR append (1MB + 1KB*20) 1.00 0.98 0.98 0.98 0.98 0.98 +506 STR append (1MB + 1KB*1000) 1.00 0.99 1.00 0.98 0.97 0.98 +507 STR append (1MB + 1MB*3) 1.00 1.00 1.00 1.00 0.99 0.99 +508 STR append (1MB + 1MB*5) 1.00 0.99 0.99 0.99 0.99 0.99 +509 STR append (1MB + 2b*1000) 1.00 0.99 1.00 0.99 0.99 0.99 +510 STR append (10KB + 1KB) 1.00 1.04 1.12 1.10 1.07 1.15 +511 STR first (failure) 1.00 0.80 1.05 0.81 0.94 1.86 +512 STR first (failure) utf 1.00 0.81 1.05 0.82 0.95 1.87 +513 STR first (success) 1.00 1.02 1.21 1.06 1.82 1.23 +514 STR first (success) utf 1.00 1.03 1.20 1.10 1.79 1.22 +515 STR first (total failure) 1.00 0.75 1.04 0.77 0.92 2.07 +516 STR first (total failure) utf 1.00 0.75 1.04 0.76 0.93 2.11 +517 STR index 0 1.00 1.02 1.14 1.05 1.72 1.31 +518 STR index 100 1.00 1.03 1.17 1.06 1.77 1.27 +519 STR index 500 1.00 1.05 1.19 1.10 1.79 1.29 +520 STR info locals match 1.00 1.06 1.06 1.05 1.07 1.04 +521 STR last (failure) 1.00 0.86 1.03 0.87 0.96 0.88 +522 STR last (success) 1.00 1.04 1.20 1.08 1.76 1.14 +523 STR last (total failure) 1.00 0.84 1.03 0.84 0.94 0.85 +524 STR length (==4010) 1.00 1.04 1.23 1.11 2.09 1.38 +525 STR length growing (1000) 1.00 1.09 1.08 1.10 1.01 1.07 +526 STR length growing uc (1000) 1.00 1.10 1.12 1.13 1.03 1.04 +527 STR length of a LIST 1.00 1.02 1.28 1.09 2.04 1.35 +528 STR length static str 1.00 1.11 1.36 1.17 2.39 1.50 +529 STR match, complex (failure) 1.00 1.15 1.02 1.16 1.06 1.02 +530 STR match, complex (success early) 1.00 1.09 1.30 1.17 1.87 1.39 +531 STR match, complex (success late) 1.00 1.13 0.98 1.14 1.03 1.01 +532 STR match, complex (total failure) 1.00 1.23 1.03 1.25 1.09 1.04 +533 STR match, exact (failure) 1.00 1.14 1.36 1.14 2.47 1.58 +534 STR match, exact (success) 1.00 1.11 1.30 1.11 2.24 1.51 +535 STR match, exact -nocase (failure) 1.00 1.08 1.29 1.11 2.18 1.53 +536 STR match, exact -nocase (success) 1.00 1.08 1.23 1.09 2.00 1.40 +537 STR match, recurse (fail backtrack) 1.00 1.00 1.01 1.00 1.04 1.01 +538 STR match, recurse (fail bt1) 1.00 1.00 1.00 1.01 1.04 1.01 +539 STR match, recurse (fail bt2) 1.00 1.00 0.99 1.01 1.03 1.00 +540 STR match, recurse (fail ranchor) 1.00 1.25 1.00 1.25 1.00 1.00 +541 STR match, recurse (success bt2) 1.00 0.98 1.02 1.01 1.24 1.07 +542 STR match, recurse2 (fail) 1.00 1.16 0.99 1.16 0.99 0.98 +543 STR match, recurse2 (success) 1.00 1.15 1.01 1.16 1.06 1.01 +544 STR match, simple (failure) 1.00 1.13 1.37 1.11 2.34 1.55 +545 STR match, simple (success) 1.00 1.13 1.36 1.10 2.21 1.51 +546 STR range, index 100..200 of 4010 1.00 1.05 1.18 1.09 1.79 1.18 +547 STR repeat, 4010 chars * 10 1.00 1.01 1.05 1.02 1.26 1.03 +548 STR repeat, 4010 chars * 100 1.00 1.00 1.01 1.01 1.05 1.01 +549 STR repeat, abcdefghij * 10 1.00 1.01 1.19 1.02 1.84 1.18 +550 STR repeat, abcdefghij * 100 1.00 1.02 1.13 1.04 1.71 1.16 +551 STR repeat, abcdefghij * 1000 1.00 0.92 1.03 1.02 1.34 1.04 +552 STR replace, equal replacement 1.00 0.90 0.97 0.91 1.56 0.95 +553 STR replace, longer replacement 1.00 1.07 1.13 1.08 1.61 0.98 +554 STR replace, no replacement 1.00 1.13 1.22 1.16 1.46 1.08 +555 STR reverse core, 10 c 1.00 1.07 1.19 1.09 1.78 1.24 +556 STR reverse core, 10 uc 1.00 1.06 1.21 1.07 1.78 1.25 +557 STR reverse core, 100 c 1.00 1.04 1.13 1.05 1.74 1.15 +558 STR reverse core, 100 uc 1.00 1.04 1.13 1.06 1.76 1.16 +559 STR reverse core, 400 c 1.00 1.03 1.04 1.04 1.78 1.14 +560 STR reverse core, 400 uc 1.00 1.05 1.05 1.05 1.83 1.13 +561 STR reverse iter/append, 10 c 1.00 0.92 1.04 0.95 1.37 1.13 +562 STR reverse iter/append, 10 uc 1.00 0.89 1.01 0.95 1.32 1.10 +563 STR reverse iter/append, 100 c 1.00 0.86 0.99 0.92 1.20 1.03 +564 STR reverse iter/append, 100 uc 1.00 0.86 1.00 0.92 1.21 1.03 +565 STR reverse iter/append, 400 c 1.00 0.86 0.97 0.88 1.18 1.00 +566 STR reverse iter/append, 400 uc 1.00 0.86 1.01 0.89 1.20 1.00 +567 STR reverse iter/set, 10 c 1.00 0.91 1.04 0.95 1.41 1.10 +568 STR reverse iter/set, 10 uc 1.00 0.90 1.02 0.94 1.39 1.09 +569 STR reverse iter/set, 100 c 1.00 0.85 0.98 0.90 1.31 1.04 +570 STR reverse iter/set, 100 uc 1.00 0.86 0.98 0.90 1.31 1.04 +571 STR reverse iter/set, 400 c 1.00 0.87 0.98 0.90 1.37 1.06 +572 STR reverse iter/set, 400 uc 1.00 0.87 0.99 0.90 1.40 1.08 +573 STR reverse recursive, 10 c 1.00 0.97 1.16 1.04 1.69 1.19 +574 STR reverse recursive, 10 uc 1.00 0.96 1.15 1.04 1.70 1.18 +575 STR reverse recursive, 100 c 1.00 1.02 1.20 1.07 1.71 1.21 +576 STR reverse recursive, 100 uc 1.00 1.02 1.21 1.07 1.71 1.22 +577 STR reverse recursive, 400 c 1.00 1.07 1.23 1.11 1.65 1.21 +578 STR reverse recursive, 400 uc 1.00 1.07 1.24 1.12 1.65 1.21 +579 STR str $a eq $b 1.00 1.07 1.15 1.06 1.65 1.27 +580 STR str $a eq $b (same obj) 1.00 1.07 1.14 1.10 1.58 1.30 +581 STR str $a equal "" 1.00 1.06 1.16 1.06 1.84 1.26 +582 STR str $a ne $b 1.00 1.06 1.12 1.07 1.58 1.16 +583 STR str $a ne $b (same obj) 1.00 1.02 1.11 1.02 1.58 1.22 +584 STR str num == "" 1.00 1.10 1.19 1.10 1.84 1.32 +585 STR strcmp bin long eq 1.00 0.97 1.03 0.97 1.34 1.08 +586 STR strcmp bin long neq 1.00 0.97 1.02 0.98 1.33 1.10 +587 STR strcmp bin long neqS 1.00 1.01 1.12 1.03 1.66 1.23 +588 STR strcmp bin short eq 1.00 0.97 1.09 0.98 1.73 1.16 +589 STR streq bin long eq 1.00 0.96 1.02 0.97 1.34 1.09 +590 STR streq bin long neq 1.00 0.97 1.02 0.99 1.32 1.10 +591 STR streq bin long neqS 1.00 0.96 1.05 0.97 1.54 1.16 +592 STR streq bin short eq 1.00 0.97 1.06 0.98 1.64 1.15 +593 STR string compare 1.00 1.00 1.17 1.01 1.76 1.28 +594 STR string compare "" 1.00 1.07 1.19 1.10 1.70 1.30 +595 STR string compare long 1.00 0.98 1.06 1.02 1.28 1.08 +596 STR string compare long (same obj) 1.00 1.03 1.16 1.06 1.71 1.26 +597 STR string compare mixed long 1.00 0.93 1.00 0.93 1.05 1.00 +598 STR string compare uni long 1.00 1.03 1.01 1.04 1.23 1.21 +599 STR string equal "" 1.00 1.03 1.12 1.05 1.78 1.26 +600 STR string equal long (!= len) 1.00 1.01 1.08 1.03 1.66 1.19 +601 STR string equal long (== len) 1.00 0.99 1.05 1.02 1.24 1.11 +602 STR string equal long (same obj) 1.00 1.04 1.11 1.11 1.54 1.21 +603 STR string equal mixed long 1.00 1.06 1.11 1.08 1.53 1.19 +604 STR string equal uni long 1.00 1.01 1.04 1.02 1.18 1.07 +605 STR/LIST length, obj shimmer 1.00 0.87 0.97 0.87 1.59 1.17 +606 SWITCH 1st true 1.00 1.14 1.30 1.12 1.98 1.34 +607 SWITCH 2nd true 1.00 1.12 1.26 1.10 2.08 1.40 +608 SWITCH 9th true 1.00 1.10 1.28 1.08 1.96 1.36 +609 SWITCH default true 1.00 1.09 1.26 1.06 2.06 1.36 +610 TRACE all set (rwu) 1.00 0.99 1.15 1.01 1.63 1.15 +611 TRACE no trace set 1.00 1.01 1.16 1.04 1.70 1.25 +612 TRACE read 1.00 0.96 1.14 1.00 1.62 1.16 +613 TRACE unset 1.00 0.99 1.17 1.01 1.62 1.15 +614 TRACE write 1.00 0.97 1.15 1.00 1.64 1.18 +615 UNSET catch var !exist 1.00 0.89 1.00 0.89 1.33 1.09 +616 UNSET catch var exists 1.00 1.14 1.29 1.14 2.19 1.45 +617 UNSET info check var !exist 1.00 1.07 1.27 1.16 2.27 1.48 +618 UNSET info check var exists 1.00 1.10 1.26 1.12 2.24 1.38 +619 UNSET nocomplain var !exist 1.00 1.13 1.28 1.10 2.31 1.46 +620 UNSET nocomplain var exists 1.00 1.11 1.29 1.08 2.34 1.47 +621 UNSET var exists 1.00 1.11 1.29 1.08 2.32 1.47 +622 UPLEVEL none 1.00 1.06 1.04 1.02 1.35 0.99 +623 UPLEVEL primed 1.00 1.09 1.22 1.02 1.89 1.16 +624 UPLEVEL to nseval 1.00 0.99 1.06 1.00 1.47 1.04 +625 UPLEVEL to proc 1.00 1.11 1.19 1.09 1.68 1.12 +626 VAR 'array set' of 100 elems 1.00 1.02 1.04 1.07 1.23 1.09 +627 VAR 100 'set's in array 1.00 1.00 1.01 1.05 1.08 1.02 +628 VAR access global 1.00 1.02 1.16 1.08 1.79 1.43 +629 VAR access local proc arg 1.00 1.11 1.28 1.09 2.07 1.50 +630 VAR access locally set 1.00 1.06 1.25 1.04 1.94 1.31 +631 VAR access upvar 1.00 1.05 1.23 1.11 1.82 1.43 +632 VAR incr global var 1000x 1.00 0.94 1.06 1.01 1.17 1.00 +633 VAR incr local var 1000x 1.00 1.02 1.11 1.11 1.20 1.02 +634 VAR incr upvar var 1000x 1.00 0.97 1.15 1.06 1.24 1.02 +635 VAR mset 1.00 0.99 1.13 0.99 1.51 1.19 +636 VAR mset (foreach) 1.00 1.02 1.17 1.03 1.80 1.32 +637 VAR ref absolute 1.00 1.05 1.04 1.09 1.26 1.06 +638 VAR ref local 1.00 1.06 1.14 1.12 1.33 1.11 +639 VAR ref variable 1.00 1.01 1.11 1.07 1.29 1.18 +640 VAR set array element 1.00 1.06 1.15 1.09 1.91 1.28 +641 VAR set scalar 1.00 1.11 1.30 1.11 2.24 1.38 +642 WORDCOUNT wc1 1.00 0.94 1.00 0.95 1.09 1.00 +643 WORDCOUNT wc2 1.00 0.90 1.00 0.93 1.34 1.13 +644 WORDCOUNT wc3 1.00 0.90 0.99 0.90 1.37 1.13 +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 +FINISHED 2011-03-19 14:37:46 -- cgit v0.12 From 060fd2cde91e18a0c1277d336f092cb708b48659 Mon Sep 17 00:00:00 2001 From: mig Date: Mon, 21 Mar 2011 11:42:06 +0000 Subject: small opts --- generic/tclAlloc.c | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 9c0ab02..e641e97 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -628,7 +628,6 @@ TclpAlloc( * allocating more blocks if necessary. */ - blockPtr = NULL; size = reqSize + OFFSET; #if RCHECK size++; @@ -642,6 +641,7 @@ TclpAlloc( } #endif } else { + blockPtr = NULL; bucket = 0; while (bucketInfo[bucket].blockSize < size) { bucket++; @@ -655,9 +655,9 @@ TclpAlloc( cachePtr->buckets[bucket].totalAssigned += reqSize; #endif } - } - if (blockPtr == NULL) { - return NULL; + if (blockPtr == NULL) { + return NULL; + } } return Block2Ptr(blockPtr, bucket, reqSize); } @@ -694,7 +694,9 @@ TclpFree( return free((char *) ptr); } +#ifdef ZIPPY_STATS GETCACHE(cachePtr); +#endif /* * Get the block back from the user pointer and call system free directly @@ -712,6 +714,10 @@ TclpFree( return; } +#ifndef ZIPPY_STATS + GETCACHE(cachePtr); +#endif + #ifdef ZIPPY_STATS cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; #endif -- cgit v0.12 From 23e778541ae5ff3bf0ef8b74c37bcd13b8f8ef94 Mon Sep 17 00:00:00 2001 From: mig Date: Mon, 21 Mar 2011 11:42:46 +0000 Subject: some cleanup re obj deletion --- generic/tclInt.decls | 6 +++--- generic/tclInt.h | 7 ------- generic/tclIntDecls.h | 8 +++----- generic/tclObj.c | 32 +++++--------------------------- generic/tclStubInit.c | 2 +- 5 files changed, 12 insertions(+), 43 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 75cb20a..4da999e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -891,9 +891,9 @@ 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[]) diff --git a/generic/tclInt.h b/generic/tclInt.h index a05007f..911cea6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2668,13 +2668,6 @@ 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; diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index dce5dae..0e9d54f 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -522,8 +522,7 @@ EXTERN TclPlatformType * TclGetPlatform(void); 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[]); @@ -826,7 +825,7 @@ typedef struct TclIntStubs { 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 */ @@ -1221,8 +1220,7 @@ extern const TclIntStubs *tclIntStubsPtr; (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 */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 5ee957d..4298f62 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -26,6 +26,10 @@ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) +#if defined(TCL_THREADS) && defined(TCL_COMPILE_STATS) +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 @@ -459,7 +463,7 @@ TclFinalizeThreadObjects(void) * TclFinalizeObjects -- * * This function is called by Tcl_Finalize to clean up all registered - * Tcl_ObjType's + * Tcl_ObjType's and to reset the tclFreeObjList. * * Results: * None. @@ -1258,7 +1262,6 @@ TclFreeObj( */ TclInvalidateStringRep(objPtr); - objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); @@ -1408,31 +1411,6 @@ TclFreeObj( /* *---------------------------------------------------------------------- * - * 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 -- * * Create and return a new object that is a duplicate of the argument diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0583961..dcf6005 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -280,7 +280,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 223 */ TclGetPlatform, /* 224 */ TclTraceDictPath, /* 225 */ - TclObjBeingDeleted, /* 226 */ + 0, /* 226 */ TclSetNsPath, /* 227 */ 0, /* 228 */ TclPtrMakeUpvar, /* 229 */ -- cgit v0.12 From e2f462108ea96728189ad727b14d981ef17ec18d Mon Sep 17 00:00:00 2001 From: mig Date: Mon, 21 Mar 2011 13:41:50 +0000 Subject: remove one level of indirection in non-mem-debug builds --- generic/tclCkalloc.c | 12 ++++++------ generic/tclInt.h | 6 ++++++ 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 3b51f68..afc6594 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -20,6 +20,12 @@ #define FALSE 0 #define TRUE 1 +#undef Tcl_Alloc +#undef Tcl_Free +#undef Tcl_Realloc +#undef Tcl_AttemptAlloc +#undef Tcl_AttemptRealloc + #ifdef TCL_MEM_DEBUG /* @@ -736,12 +742,6 @@ Tcl_AttemptDbCkrealloc( *---------------------------------------------------------------------- */ -#undef Tcl_Alloc -#undef Tcl_Free -#undef Tcl_Realloc -#undef Tcl_AttemptAlloc -#undef Tcl_AttemptRealloc - char * Tcl_Alloc( unsigned int size) diff --git a/generic/tclInt.h b/generic/tclInt.h index 911cea6..f728a80 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4500,6 +4500,12 @@ typedef struct NRE_callback { #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" +#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) +#define Tcl_AttemptAlloc TclpAlloc +#define Tcl_AttemptRealloc TclpRealloc +#define Tcl_Free TclpFree +#endif + #endif /* _TCLINT */ /* -- cgit v0.12 From b3db9be3e756f6c6e6267a5691d47d6c5d5acf6d Mon Sep 17 00:00:00 2001 From: mig Date: Mon, 21 Mar 2011 14:38:05 +0000 Subject: fix last commit --- generic/tclInt.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index f728a80..a22348f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4501,9 +4501,9 @@ typedef struct NRE_callback { #include "tclTomMathDecls.h" #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) -#define Tcl_AttemptAlloc TclpAlloc -#define Tcl_AttemptRealloc TclpRealloc -#define Tcl_Free TclpFree +#define Tcl_AttemptAlloc(size) TclpAlloc(size) +#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size)) +#define Tcl_Free(ptr) TclpFree(ptr) #endif #endif /* _TCLINT */ -- cgit v0.12