summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xgeneric/tclThreadAlloc.c1903
-rw-r--r--win/tclAppInit.c898
2 files changed, 1401 insertions, 1400 deletions
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 0b428a6..5ff9449 100755
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -1,951 +1,952 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclThreadAlloc.c,v 1.5 2003/05/09 23:33:55 mistachkin Exp $ */
-
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
-
-#include "tclInt.h"
-
-#ifdef WIN32
-#include "tclWinInt.h"
-#else
-extern Tcl_Mutex *TclpNewAllocMutex(void);
-extern void *TclpGetAllocCache(void);
-extern void TclpSetAllocCache(void *);
-#endif
-
-/*
- * 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
-#define NOBJHIGH 1200
-
-/*
- * The following defines the number of buckets in the bucket
- * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS))
- */
-
-#define NBUCKETS 11
-#define MAXALLOC 16284
-
-/*
- * 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 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. */
- } b_s;
- } b_u;
- size_t b_reqsize; /* Requested allocation size. */
-} Block;
-#define b_next b_u.next
-#define b_bucket b_u.b_s.bucket
-#define b_magic1 b_u.b_s.magic1
-#define b_magic2 b_u.b_s.magic2
-#define MAGIC 0xef
-
-/*
- * The following structure defines a bucket of blocks with
- * various accounting and statistics information.
- */
-
-typedef struct Bucket {
- Block *firstPtr;
- int nfree;
- int nget;
- int nput;
- int nwait;
- int nlock;
- int nrequest;
-} Bucket;
-
-/*
- * The following structure defines a cache of buckets and objs.
- */
-
-typedef struct Cache {
- struct Cache *nextPtr;
- Tcl_ThreadId owner;
- Tcl_Obj *firstObjPtr;
- int nobjs;
- int nsysalloc;
- Bucket buckets[NBUCKETS];
-} Cache;
-
-/*
- * The following array specifies various per-bucket
- * limits and locks. The values are statically initialized
- * to avoid calculating them repeatedly.
- */
-
-struct binfo {
- size_t blocksize; /* Bucket blocksize. */
- int maxblocks; /* Max blocks before move to share. */
- int nmove; /* Num blocks to move to share. */
- Tcl_Mutex *lockPtr; /* Share bucket lock. */
-} binfo[NBUCKETS] = {
- { 16, 1024, 512, NULL},
- { 32, 512, 256, NULL},
- { 64, 256, 128, NULL},
- { 128, 128, 64, NULL},
- { 256, 64, 32, NULL},
- { 512, 32, 16, NULL},
- { 1024, 16, 8, NULL},
- { 2048, 8, 4, NULL},
- { 4096, 4, 2, NULL},
- { 8192, 2, 1, NULL},
- {16284, 1, 1, NULL},
-};
-
-/*
- * Static functions defined in this file.
- */
-
-static void LockBucket(Cache *cachePtr, int bucket);
-static void UnlockBucket(Cache *cachePtr, int bucket);
-static void PutBlocks(Cache *cachePtr, int bucket, int nmove);
-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 nmove);
-
-/*
- * 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;
- int i;
-
- initLockPtr = Tcl_GetAllocMutex();
- Tcl_MutexLock(initLockPtr);
- if (listLockPtr == NULL) {
- listLockPtr = TclpNewAllocMutex();
- objLockPtr = TclpNewAllocMutex();
- for (i = 0; i < NBUCKETS; ++i) {
- binfo[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) {
- 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 int bucket;
-
- /*
- * Flush blocks.
- */
-
- for (bucket = 0; bucket < NBUCKETS; ++bucket) {
- if (cachePtr->buckets[bucket].nfree > 0) {
- PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].nfree);
- }
- }
-
- /*
- * Flush objs.
- */
-
- if (cachePtr->nobjs > 0) {
- Tcl_MutexLock(objLockPtr);
- MoveObjs(cachePtr, sharedPtr, cachePtr->nobjs);
- 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 = TclpGetAllocCache();
- Block *blockPtr;
- register int bucket;
- size_t size;
-
- 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->nsysalloc += reqsize;
- }
- } else {
- bucket = 0;
- while (binfo[bucket].blocksize < size) {
- ++bucket;
- }
- if (cachePtr->buckets[bucket].nfree || GetBlocks(cachePtr, bucket)) {
- blockPtr = cachePtr->buckets[bucket].firstPtr;
- cachePtr->buckets[bucket].firstPtr = blockPtr->b_next;
- --cachePtr->buckets[bucket].nfree;
- ++cachePtr->buckets[bucket].nget;
- cachePtr->buckets[bucket].nrequest += 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)
-{
- if (ptr != NULL) {
- Cache *cachePtr = TclpGetAllocCache();
- Block *blockPtr;
- int bucket;
-
- 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->b_bucket;
- if (bucket == NBUCKETS) {
- cachePtr->nsysalloc -= blockPtr->b_reqsize;
- free(blockPtr);
- } else {
- cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
- blockPtr->b_next = cachePtr->buckets[bucket].firstPtr;
- cachePtr->buckets[bucket].firstPtr = blockPtr;
- ++cachePtr->buckets[bucket].nfree;
- ++cachePtr->buckets[bucket].nput;
- if (cachePtr != sharedPtr &&
- cachePtr->buckets[bucket].nfree > binfo[bucket].maxblocks) {
- PutBlocks(cachePtr, bucket, binfo[bucket].nmove);
- }
- }
- }
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 = TclpGetAllocCache();
- Block *blockPtr;
- void *new;
- size_t size, min;
- int bucket;
-
- if (ptr == NULL) {
- return TclpAlloc(reqsize);
- }
-
- 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->b_bucket;
- if (bucket != NBUCKETS) {
- if (bucket > 0) {
- min = binfo[bucket-1].blocksize;
- } else {
- min = 0;
- }
- if (size > min && size <= binfo[bucket].blocksize) {
- cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
- cachePtr->buckets[bucket].nrequest += reqsize;
- return Block2Ptr(blockPtr, bucket, reqsize);
- }
- } else if (size > MAXALLOC) {
- cachePtr->nsysalloc -= blockPtr->b_reqsize;
- cachePtr->nsysalloc += reqsize;
- blockPtr = realloc(blockPtr, size);
- if (blockPtr == NULL) {
- return NULL;
- }
- return Block2Ptr(blockPtr, NBUCKETS, reqsize);
- }
-
- /*
- * Finally, perform an expensive malloc/copy/free.
- */
-
- new = TclpAlloc(reqsize);
- if (new != NULL) {
- if (reqsize > blockPtr->b_reqsize) {
- reqsize = blockPtr->b_reqsize;
- }
- memcpy(new, ptr, reqsize);
- TclpFree(ptr);
- }
- return new;
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclThreadAllocObj(void)
-{
- register Cache *cachePtr = TclpGetAllocCache();
- register int nmove;
- register Tcl_Obj *objPtr;
- Tcl_Obj *newObjsPtr;
-
- if (cachePtr == NULL) {
- cachePtr = GetCache();
- }
-
- /*
- * Get this thread's obj list structure and move
- * or allocate new objs if necessary.
- */
-
- if (cachePtr->nobjs == 0) {
- Tcl_MutexLock(objLockPtr);
- nmove = sharedPtr->nobjs;
- if (nmove > 0) {
- if (nmove > NOBJALLOC) {
- nmove = NOBJALLOC;
- }
- MoveObjs(sharedPtr, cachePtr, nmove);
- }
- Tcl_MutexUnlock(objLockPtr);
- if (cachePtr->nobjs == 0) {
- cachePtr->nobjs = nmove = NOBJALLOC;
- newObjsPtr = malloc(sizeof(Tcl_Obj) * nmove);
- if (newObjsPtr == NULL) {
- panic("alloc: could not allocate %d new objects", nmove);
- }
- while (--nmove >= 0) {
- objPtr = &newObjsPtr[nmove];
- objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
- cachePtr->firstObjPtr = objPtr;
- }
- }
- }
-
- /*
- * Pop the first object.
- */
-
- objPtr = cachePtr->firstObjPtr;
- cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
- --cachePtr->nobjs;
- 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.
- *
- *----------------------------------------------------------------------
- */
-
-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->nobjs;
-
- /*
- * If the number of free objects has exceeded the high
- * water mark, move some blocks to the shared list.
- */
-
- if (cachePtr->nobjs > 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];
- int n;
-
- Tcl_MutexLock(listLockPtr);
- cachePtr = firstCachePtr;
- while (cachePtr != NULL) {
- Tcl_DStringStartSublist(dsPtr);
- if (cachePtr == sharedPtr) {
- Tcl_DStringAppendElement(dsPtr, "shared");
- } else {
- sprintf(buf, "thread%d", (int) cachePtr->owner);
- Tcl_DStringAppendElement(dsPtr, buf);
- }
- for (n = 0; n < NBUCKETS; ++n) {
- sprintf(buf, "%d %d %d %d %d %d %d",
- (int) binfo[n].blocksize,
- cachePtr->buckets[n].nfree,
- cachePtr->buckets[n].nget,
- cachePtr->buckets[n].nput,
- cachePtr->buckets[n].nrequest,
- cachePtr->buckets[n].nlock,
- cachePtr->buckets[n].nwait);
- 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 nmove)
-{
- register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
- Tcl_Obj *fromFirstObjPtr = objPtr;
-
- toPtr->nobjs += nmove;
- fromPtr->nobjs -= nmove;
-
- /*
- * 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 (--nmove) {
- 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->b_magic1 = blockPtr->b_magic2 = MAGIC;
- blockPtr->b_bucket = bucket;
- blockPtr->b_reqsize = 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->b_magic1 != MAGIC
-#if RCHECK
- || ((unsigned char *) ptr)[blockPtr->b_reqsize] != MAGIC
-#endif
- || blockPtr->b_magic2 != MAGIC) {
- panic("alloc: invalid block: %p: %x %x %x\n",
- blockPtr, blockPtr->b_magic1, blockPtr->b_magic2,
- ((unsigned char *) ptr)[blockPtr->b_reqsize]);
- }
- 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(binfo[bucket].lockPtr) != TCL_OK) {
- Tcl_MutexLock(binfo[bucket].lockPtr);
- ++cachePtr->buckets[bucket].nwait;
- ++sharedPtr->buckets[bucket].nwait;
- }
-#else
- Tcl_MutexLock(binfo[bucket].lockPtr);
-#endif
- ++cachePtr->buckets[bucket].nlock;
- ++sharedPtr->buckets[bucket].nlock;
-}
-
-
-static void
-UnlockBucket(Cache *cachePtr, int bucket)
-{
- Tcl_MutexUnlock(binfo[bucket].lockPtr);
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * PutBlocks --
- *
- * Return unused blocks to the shared cache.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-PutBlocks(Cache *cachePtr, int bucket, int nmove)
-{
- register Block *lastPtr, *firstPtr;
- register int n = nmove;
-
- /*
- * 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->b_next;
- }
- cachePtr->buckets[bucket].firstPtr = lastPtr->b_next;
- cachePtr->buckets[bucket].nfree -= nmove;
-
- /*
- * Aquire the lock and place the list of blocks at the front
- * of the shared cache bucket.
- */
-
- LockBucket(cachePtr, bucket);
- lastPtr->b_next = sharedPtr->buckets[bucket].firstPtr;
- sharedPtr->buckets[bucket].firstPtr = firstPtr;
- sharedPtr->buckets[bucket].nfree += nmove;
- 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;
- register size_t size;
-
- /*
- * First, atttempt to move blocks from the shared cache. Note
- * the potentially dirty read of nfree 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].nfree > 0) {
- LockBucket(cachePtr, bucket);
- if (sharedPtr->buckets[bucket].nfree > 0) {
-
- /*
- * Either move the entire list or walk the list to find
- * the last block to move.
- */
-
- n = binfo[bucket].nmove;
- if (n >= sharedPtr->buckets[bucket].nfree) {
- cachePtr->buckets[bucket].firstPtr =
- sharedPtr->buckets[bucket].firstPtr;
- cachePtr->buckets[bucket].nfree =
- sharedPtr->buckets[bucket].nfree;
- sharedPtr->buckets[bucket].firstPtr = NULL;
- sharedPtr->buckets[bucket].nfree = 0;
- } else {
- blockPtr = sharedPtr->buckets[bucket].firstPtr;
- cachePtr->buckets[bucket].firstPtr = blockPtr;
- sharedPtr->buckets[bucket].nfree -= n;
- cachePtr->buckets[bucket].nfree = n;
- while (--n > 0) {
- blockPtr = blockPtr->b_next;
- }
- sharedPtr->buckets[bucket].firstPtr = blockPtr->b_next;
- blockPtr->b_next = NULL;
- }
- }
- UnlockBucket(cachePtr, bucket);
- }
-
- if (cachePtr->buckets[bucket].nfree == 0) {
-
- /*
- * 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].nfree > 0) {
- size = binfo[n].blocksize;
- blockPtr = cachePtr->buckets[n].firstPtr;
- cachePtr->buckets[n].firstPtr = blockPtr->b_next;
- --cachePtr->buckets[n].nfree;
- 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 / binfo[bucket].blocksize;
- cachePtr->buckets[bucket].nfree = n;
- cachePtr->buckets[bucket].firstPtr = blockPtr;
- while (--n > 0) {
- blockPtr->b_next = (Block *)
- ((char *) blockPtr + binfo[bucket].blocksize);
- blockPtr = blockPtr->b_next;
- }
- blockPtr->b_next = NULL;
- }
- return 1;
-}
-
-#endif /* TCL_THREADS */
+/*
+ * 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.
+ *
+ * RCS: @(#) $Id: tclThreadAlloc.c,v 1.6 2003/05/10 04:28:59 mistachkin Exp $
+ */
+
+#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+
+#include "tclInt.h"
+
+#ifdef WIN32
+#include "tclWinInt.h"
+#else
+extern Tcl_Mutex *TclpNewAllocMutex(void);
+extern void *TclpGetAllocCache(void);
+extern void TclpSetAllocCache(void *);
+#endif
+
+/*
+ * 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
+#define NOBJHIGH 1200
+
+/*
+ * The following defines the number of buckets in the bucket
+ * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS))
+ */
+
+#define NBUCKETS 11
+#define MAXALLOC 16284
+
+/*
+ * 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 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. */
+ } b_s;
+ } b_u;
+ size_t b_reqsize; /* Requested allocation size. */
+} Block;
+#define b_next b_u.next
+#define b_bucket b_u.b_s.bucket
+#define b_magic1 b_u.b_s.magic1
+#define b_magic2 b_u.b_s.magic2
+#define MAGIC 0xef
+
+/*
+ * The following structure defines a bucket of blocks with
+ * various accounting and statistics information.
+ */
+
+typedef struct Bucket {
+ Block *firstPtr;
+ int nfree;
+ int nget;
+ int nput;
+ int nwait;
+ int nlock;
+ int nrequest;
+} Bucket;
+
+/*
+ * The following structure defines a cache of buckets and objs.
+ */
+
+typedef struct Cache {
+ struct Cache *nextPtr;
+ Tcl_ThreadId owner;
+ Tcl_Obj *firstObjPtr;
+ int nobjs;
+ int nsysalloc;
+ Bucket buckets[NBUCKETS];
+} Cache;
+
+/*
+ * The following array specifies various per-bucket
+ * limits and locks. The values are statically initialized
+ * to avoid calculating them repeatedly.
+ */
+
+struct binfo {
+ size_t blocksize; /* Bucket blocksize. */
+ int maxblocks; /* Max blocks before move to share. */
+ int nmove; /* Num blocks to move to share. */
+ Tcl_Mutex *lockPtr; /* Share bucket lock. */
+} binfo[NBUCKETS] = {
+ { 16, 1024, 512, NULL},
+ { 32, 512, 256, NULL},
+ { 64, 256, 128, NULL},
+ { 128, 128, 64, NULL},
+ { 256, 64, 32, NULL},
+ { 512, 32, 16, NULL},
+ { 1024, 16, 8, NULL},
+ { 2048, 8, 4, NULL},
+ { 4096, 4, 2, NULL},
+ { 8192, 2, 1, NULL},
+ {16284, 1, 1, NULL},
+};
+
+/*
+ * Static functions defined in this file.
+ */
+
+static void LockBucket(Cache *cachePtr, int bucket);
+static void UnlockBucket(Cache *cachePtr, int bucket);
+static void PutBlocks(Cache *cachePtr, int bucket, int nmove);
+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 nmove);
+
+/*
+ * 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;
+ int i;
+
+ initLockPtr = Tcl_GetAllocMutex();
+ Tcl_MutexLock(initLockPtr);
+ if (listLockPtr == NULL) {
+ listLockPtr = TclpNewAllocMutex();
+ objLockPtr = TclpNewAllocMutex();
+ for (i = 0; i < NBUCKETS; ++i) {
+ binfo[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) {
+ 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 int bucket;
+
+ /*
+ * Flush blocks.
+ */
+
+ for (bucket = 0; bucket < NBUCKETS; ++bucket) {
+ if (cachePtr->buckets[bucket].nfree > 0) {
+ PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].nfree);
+ }
+ }
+
+ /*
+ * Flush objs.
+ */
+
+ if (cachePtr->nobjs > 0) {
+ Tcl_MutexLock(objLockPtr);
+ MoveObjs(cachePtr, sharedPtr, cachePtr->nobjs);
+ 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 = TclpGetAllocCache();
+ Block *blockPtr;
+ register int bucket;
+ size_t size;
+
+ 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->nsysalloc += reqsize;
+ }
+ } else {
+ bucket = 0;
+ while (binfo[bucket].blocksize < size) {
+ ++bucket;
+ }
+ if (cachePtr->buckets[bucket].nfree || GetBlocks(cachePtr, bucket)) {
+ blockPtr = cachePtr->buckets[bucket].firstPtr;
+ cachePtr->buckets[bucket].firstPtr = blockPtr->b_next;
+ --cachePtr->buckets[bucket].nfree;
+ ++cachePtr->buckets[bucket].nget;
+ cachePtr->buckets[bucket].nrequest += 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)
+{
+ if (ptr != NULL) {
+ Cache *cachePtr = TclpGetAllocCache();
+ Block *blockPtr;
+ int bucket;
+
+ 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->b_bucket;
+ if (bucket == NBUCKETS) {
+ cachePtr->nsysalloc -= blockPtr->b_reqsize;
+ free(blockPtr);
+ } else {
+ cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
+ blockPtr->b_next = cachePtr->buckets[bucket].firstPtr;
+ cachePtr->buckets[bucket].firstPtr = blockPtr;
+ ++cachePtr->buckets[bucket].nfree;
+ ++cachePtr->buckets[bucket].nput;
+ if (cachePtr != sharedPtr &&
+ cachePtr->buckets[bucket].nfree > binfo[bucket].maxblocks) {
+ PutBlocks(cachePtr, bucket, binfo[bucket].nmove);
+ }
+ }
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = TclpGetAllocCache();
+ Block *blockPtr;
+ void *new;
+ size_t size, min;
+ int bucket;
+
+ if (ptr == NULL) {
+ return TclpAlloc(reqsize);
+ }
+
+ 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->b_bucket;
+ if (bucket != NBUCKETS) {
+ if (bucket > 0) {
+ min = binfo[bucket-1].blocksize;
+ } else {
+ min = 0;
+ }
+ if (size > min && size <= binfo[bucket].blocksize) {
+ cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
+ cachePtr->buckets[bucket].nrequest += reqsize;
+ return Block2Ptr(blockPtr, bucket, reqsize);
+ }
+ } else if (size > MAXALLOC) {
+ cachePtr->nsysalloc -= blockPtr->b_reqsize;
+ cachePtr->nsysalloc += reqsize;
+ blockPtr = realloc(blockPtr, size);
+ if (blockPtr == NULL) {
+ return NULL;
+ }
+ return Block2Ptr(blockPtr, NBUCKETS, reqsize);
+ }
+
+ /*
+ * Finally, perform an expensive malloc/copy/free.
+ */
+
+ new = TclpAlloc(reqsize);
+ if (new != NULL) {
+ if (reqsize > blockPtr->b_reqsize) {
+ reqsize = blockPtr->b_reqsize;
+ }
+ memcpy(new, ptr, reqsize);
+ TclpFree(ptr);
+ }
+ return new;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclThreadAllocObj(void)
+{
+ register Cache *cachePtr = TclpGetAllocCache();
+ register int nmove;
+ register Tcl_Obj *objPtr;
+ Tcl_Obj *newObjsPtr;
+
+ if (cachePtr == NULL) {
+ cachePtr = GetCache();
+ }
+
+ /*
+ * Get this thread's obj list structure and move
+ * or allocate new objs if necessary.
+ */
+
+ if (cachePtr->nobjs == 0) {
+ Tcl_MutexLock(objLockPtr);
+ nmove = sharedPtr->nobjs;
+ if (nmove > 0) {
+ if (nmove > NOBJALLOC) {
+ nmove = NOBJALLOC;
+ }
+ MoveObjs(sharedPtr, cachePtr, nmove);
+ }
+ Tcl_MutexUnlock(objLockPtr);
+ if (cachePtr->nobjs == 0) {
+ cachePtr->nobjs = nmove = NOBJALLOC;
+ newObjsPtr = malloc(sizeof(Tcl_Obj) * nmove);
+ if (newObjsPtr == NULL) {
+ panic("alloc: could not allocate %d new objects", nmove);
+ }
+ while (--nmove >= 0) {
+ objPtr = &newObjsPtr[nmove];
+ objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
+ cachePtr->firstObjPtr = objPtr;
+ }
+ }
+ }
+
+ /*
+ * Pop the first object.
+ */
+
+ objPtr = cachePtr->firstObjPtr;
+ cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
+ --cachePtr->nobjs;
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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->nobjs;
+
+ /*
+ * If the number of free objects has exceeded the high
+ * water mark, move some blocks to the shared list.
+ */
+
+ if (cachePtr->nobjs > 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];
+ int n;
+
+ Tcl_MutexLock(listLockPtr);
+ cachePtr = firstCachePtr;
+ while (cachePtr != NULL) {
+ Tcl_DStringStartSublist(dsPtr);
+ if (cachePtr == sharedPtr) {
+ Tcl_DStringAppendElement(dsPtr, "shared");
+ } else {
+ sprintf(buf, "thread%d", (int) cachePtr->owner);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+ for (n = 0; n < NBUCKETS; ++n) {
+ sprintf(buf, "%d %d %d %d %d %d %d",
+ (int) binfo[n].blocksize,
+ cachePtr->buckets[n].nfree,
+ cachePtr->buckets[n].nget,
+ cachePtr->buckets[n].nput,
+ cachePtr->buckets[n].nrequest,
+ cachePtr->buckets[n].nlock,
+ cachePtr->buckets[n].nwait);
+ 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 nmove)
+{
+ register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
+ Tcl_Obj *fromFirstObjPtr = objPtr;
+
+ toPtr->nobjs += nmove;
+ fromPtr->nobjs -= nmove;
+
+ /*
+ * 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 (--nmove) {
+ 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->b_magic1 = blockPtr->b_magic2 = MAGIC;
+ blockPtr->b_bucket = bucket;
+ blockPtr->b_reqsize = 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->b_magic1 != MAGIC
+#if RCHECK
+ || ((unsigned char *) ptr)[blockPtr->b_reqsize] != MAGIC
+#endif
+ || blockPtr->b_magic2 != MAGIC) {
+ panic("alloc: invalid block: %p: %x %x %x\n",
+ blockPtr, blockPtr->b_magic1, blockPtr->b_magic2,
+ ((unsigned char *) ptr)[blockPtr->b_reqsize]);
+ }
+ 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(binfo[bucket].lockPtr) != TCL_OK) {
+ Tcl_MutexLock(binfo[bucket].lockPtr);
+ ++cachePtr->buckets[bucket].nwait;
+ ++sharedPtr->buckets[bucket].nwait;
+ }
+#else
+ Tcl_MutexLock(binfo[bucket].lockPtr);
+#endif
+ ++cachePtr->buckets[bucket].nlock;
+ ++sharedPtr->buckets[bucket].nlock;
+}
+
+
+static void
+UnlockBucket(Cache *cachePtr, int bucket)
+{
+ Tcl_MutexUnlock(binfo[bucket].lockPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PutBlocks --
+ *
+ * Return unused blocks to the shared cache.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PutBlocks(Cache *cachePtr, int bucket, int nmove)
+{
+ register Block *lastPtr, *firstPtr;
+ register int n = nmove;
+
+ /*
+ * 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->b_next;
+ }
+ cachePtr->buckets[bucket].firstPtr = lastPtr->b_next;
+ cachePtr->buckets[bucket].nfree -= nmove;
+
+ /*
+ * Aquire the lock and place the list of blocks at the front
+ * of the shared cache bucket.
+ */
+
+ LockBucket(cachePtr, bucket);
+ lastPtr->b_next = sharedPtr->buckets[bucket].firstPtr;
+ sharedPtr->buckets[bucket].firstPtr = firstPtr;
+ sharedPtr->buckets[bucket].nfree += nmove;
+ 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;
+ register size_t size;
+
+ /*
+ * First, atttempt to move blocks from the shared cache. Note
+ * the potentially dirty read of nfree 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].nfree > 0) {
+ LockBucket(cachePtr, bucket);
+ if (sharedPtr->buckets[bucket].nfree > 0) {
+
+ /*
+ * Either move the entire list or walk the list to find
+ * the last block to move.
+ */
+
+ n = binfo[bucket].nmove;
+ if (n >= sharedPtr->buckets[bucket].nfree) {
+ cachePtr->buckets[bucket].firstPtr =
+ sharedPtr->buckets[bucket].firstPtr;
+ cachePtr->buckets[bucket].nfree =
+ sharedPtr->buckets[bucket].nfree;
+ sharedPtr->buckets[bucket].firstPtr = NULL;
+ sharedPtr->buckets[bucket].nfree = 0;
+ } else {
+ blockPtr = sharedPtr->buckets[bucket].firstPtr;
+ cachePtr->buckets[bucket].firstPtr = blockPtr;
+ sharedPtr->buckets[bucket].nfree -= n;
+ cachePtr->buckets[bucket].nfree = n;
+ while (--n > 0) {
+ blockPtr = blockPtr->b_next;
+ }
+ sharedPtr->buckets[bucket].firstPtr = blockPtr->b_next;
+ blockPtr->b_next = NULL;
+ }
+ }
+ UnlockBucket(cachePtr, bucket);
+ }
+
+ if (cachePtr->buckets[bucket].nfree == 0) {
+
+ /*
+ * 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].nfree > 0) {
+ size = binfo[n].blocksize;
+ blockPtr = cachePtr->buckets[n].firstPtr;
+ cachePtr->buckets[n].firstPtr = blockPtr->b_next;
+ --cachePtr->buckets[n].nfree;
+ 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 / binfo[bucket].blocksize;
+ cachePtr->buckets[bucket].nfree = n;
+ cachePtr->buckets[bucket].firstPtr = blockPtr;
+ while (--n > 0) {
+ blockPtr->b_next = (Block *)
+ ((char *) blockPtr + binfo[bucket].blocksize);
+ blockPtr = blockPtr->b_next;
+ }
+ blockPtr->b_next = NULL;
+ }
+ return 1;
+}
+
+#endif /* TCL_THREADS */
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index 38fd50d..19acfe0 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -1,449 +1,449 @@
-/*
- * tclAppInit.c --
- *
- * Provides a default version of the main program and Tcl_AppInit
- * procedure for Tcl applications (without Tk). Note that this
- * program must be built in Win32 console mode to work properly.
- *
- * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclAppInit.c,v 1.12 2003/05/10 02:52:54 mistachkin Exp $
- */
-
-#include "tcl.h"
-#include <windows.h>
-#include <locale.h>
-
-#ifdef TCL_TEST
-extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));
-extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-#ifdef TCL_THREADS
-extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
-#endif
-#endif /* TCL_TEST */
-
-static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
-static BOOL __stdcall sigHandler (DWORD fdwCtrlType);
-static Tcl_AsyncProc asyncExit;
-static void AppInitExitHandler(ClientData clientData);
-
-static char ** argvSave = NULL;
-static Tcl_AsyncHandler exitToken = NULL;
-static DWORD exitErrorCode = 0;
-
-
-/*
- *----------------------------------------------------------------------
- *
- * main --
- *
- * This is the main program for the application.
- *
- * Results:
- * None: Tcl_Main never returns here, so this procedure never
- * returns either.
- *
- * Side effects:
- * Whatever the application does.
- *
- *----------------------------------------------------------------------
- */
-
-int
-main(argc, argv)
- int argc; /* Number of command-line arguments. */
- char **argv; /* Values of command-line arguments. */
-{
- /*
- * The following #if block allows you to change the AppInit
- * function by using a #define of TCL_LOCAL_APPINIT instead
- * of rewriting this entire file. The #if checks for that
- * #define and uses Tcl_AppInit if it doesn't exist.
- */
-
-#ifndef TCL_LOCAL_APPINIT
-#define TCL_LOCAL_APPINIT Tcl_AppInit
-#endif
- extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));
-
- /*
- * The following #if block allows you to change how Tcl finds the startup
- * script, prime the library or encoding paths, fiddle with the argv,
- * etc., without needing to rewrite Tcl_Main()
- */
-
-#ifdef TCL_LOCAL_MAIN_HOOK
- extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));
-#endif
-
- char buffer[MAX_PATH +1];
- char *p;
- /*
- * Set up the default locale to be standard "C" locale so parsing
- * is performed correctly.
- */
-
- setlocale(LC_ALL, "C");
- setargv(&argc, &argv);
-
- /*
- * Save this for later, so we can free it.
- */
- argvSave = argv;
-
- /*
- * Replace argv[0] with full pathname of executable, and forward
- * slashes substituted for backslashes.
- */
-
- GetModuleFileName(NULL, buffer, sizeof(buffer));
- argv[0] = buffer;
- for (p = buffer; *p != '\0'; p++) {
- if (*p == '\\') {
- *p = '/';
- }
- }
-
-#ifdef TCL_LOCAL_MAIN_HOOK
- TCL_LOCAL_MAIN_HOOK(&argc, &argv);
-#endif
-
- Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
-
- return 0; /* Needed only to prevent compiler warning. */
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppInit --
- *
- * This procedure performs application-specific initialization.
- * Most applications, especially those that incorporate additional
- * packages, will have their own version of this procedure.
- *
- * Results:
- * Returns a standard Tcl completion code, and leaves an error
- * message in the interp's result if an error occurs.
- *
- * Side effects:
- * Depends on the startup script.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_AppInit(interp)
- Tcl_Interp *interp; /* Interpreter for application. */
-{
- if (Tcl_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-
- /*
- * Install a signal handler to the win32 console tclsh is running in.
- */
- SetConsoleCtrlHandler(sigHandler, TRUE);
- exitToken = Tcl_AsyncCreate(asyncExit, NULL);
-
- /*
- * This exit handler will be used to free the
- * resources allocated in this file.
- */
- Tcl_CreateExitHandler(AppInitExitHandler, NULL);
-
-#ifdef TCL_TEST
- if (Tcltest_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
- (Tcl_PackageInitProc *) NULL);
- if (TclObjTest_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-#ifdef TCL_THREADS
- if (TclThread_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-#endif
- if (Procbodytest_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
- Procbodytest_SafeInit);
-#endif /* TCL_TEST */
-
-#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES)
- {
- extern Tcl_PackageInitProc Registry_Init;
- extern Tcl_PackageInitProc Dde_Init;
-
- if (Registry_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "registry", Registry_Init, NULL);
-
- if (Dde_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "dde", Dde_Init, NULL);
- }
-#endif
-
- /*
- * Call the init procedures for included packages. Each call should
- * look like this:
- *
- * if (Mod_Init(interp) == TCL_ERROR) {
- * return TCL_ERROR;
- * }
- *
- * where "Mod" is the name of the module.
- */
-
- /*
- * Call Tcl_CreateCommand for application-specific commands, if
- * they weren't already created by the init procedures called above.
- */
-
- /*
- * Specify a user-specific startup file to invoke if the application
- * is run interactively. Typically the startup file is "~/.apprc"
- * where "app" is the name of the application. If this line is deleted
- * then no user-specific startup file will be run under any conditions.
- */
-
- Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AppInitExitHandler --
- *
- * This function is called to cleanup the app init resources before
- * Tcl is unloaded.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Frees the saved argv and deletes the async exit handler.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AppInitExitHandler(
- ClientData clientData)
-{
- if (argvSave != NULL) {
- ckfree((char *)argvSave);
- argvSave = NULL;
- }
-
- if (exitToken != NULL) {
- /*
- * This should be safe to do even if we
- * are in an async exit right now.
- */
- Tcl_AsyncDelete(exitToken);
- exitToken = NULL;
- }
-}
-
-/*
- *-------------------------------------------------------------------------
- *
- * setargv --
- *
- * Parse the Windows command line string into argc/argv. Done here
- * because we don't trust the builtin argument parser in crt0.
- * Windows applications are responsible for breaking their command
- * line into arguments.
- *
- * 2N backslashes + quote -> N backslashes + begin quoted string
- * 2N + 1 backslashes + quote -> literal
- * N backslashes + non-quote -> literal
- * quote + quote in a quoted string -> single quote
- * quote + quote not in quoted string -> empty string
- * quote -> begin quoted string
- *
- * Results:
- * Fills argcPtr with the number of arguments and argvPtr with the
- * array of arguments.
- *
- * Side effects:
- * Memory allocated.
- *
- *--------------------------------------------------------------------------
- */
-
-static void
-setargv(argcPtr, argvPtr)
- int *argcPtr; /* Filled with number of argument strings. */
- char ***argvPtr; /* Filled with argument strings (malloc'd). */
-{
- char *cmdLine, *p, *arg, *argSpace;
- char **argv;
- int argc, size, inquote, copy, slashes;
-
- cmdLine = GetCommandLine(); /* INTL: BUG */
-
- /*
- * Precompute an overly pessimistic guess at the number of arguments
- * in the command line by counting non-space spans.
- */
-
- size = 2;
- for (p = cmdLine; *p != '\0'; p++) {
- if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
- size++;
- while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
- p++;
- }
- if (*p == '\0') {
- break;
- }
- }
- }
- argSpace = (char *) Tcl_Alloc(
- (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
- argv = (char **) argSpace;
- argSpace += size * sizeof(char *);
- size--;
-
- p = cmdLine;
- for (argc = 0; argc < size; argc++) {
- argv[argc] = arg = argSpace;
- while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
- p++;
- }
- if (*p == '\0') {
- break;
- }
-
- inquote = 0;
- slashes = 0;
- while (1) {
- copy = 1;
- while (*p == '\\') {
- slashes++;
- p++;
- }
- if (*p == '"') {
- if ((slashes & 1) == 0) {
- copy = 0;
- if ((inquote) && (p[1] == '"')) {
- p++;
- copy = 1;
- } else {
- inquote = !inquote;
- }
- }
- slashes >>= 1;
- }
-
- while (slashes) {
- *arg = '\\';
- arg++;
- slashes--;
- }
-
- if ((*p == '\0')
- || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
- break;
- }
- if (copy != 0) {
- *arg = *p;
- arg++;
- }
- p++;
- }
- *arg = '\0';
- argSpace = arg + 1;
- }
- argv[argc] = NULL;
-
- *argcPtr = argc;
- *argvPtr = argv;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * asyncExit --
- *
- * The AsyncProc for the exitToken.
- *
- * Results:
- * doesn't actually return.
- *
- * Side effects:
- * tclsh cleanly exits.
- *
- *----------------------------------------------------------------------
- */
-
-int
-asyncExit (ClientData clientData, Tcl_Interp *interp, int code)
-{
- Tcl_Exit((int)exitErrorCode);
-
- /* NOTREACHED */
- return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * sigHandler --
- *
- * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and
- * other exits. This is needed so tclsh can do it's real clean-up
- * and not an unclean crash terminate.
- *
- * Results:
- * TRUE.
- *
- * Side effects:
- * Effects the way the app exits from a signal. This is an
- * operating system supplied thread and unsafe to call ANY
- * Tcl commands except for Tcl_AsyncMark.
- *
- *----------------------------------------------------------------------
- */
-
-BOOL __stdcall
-sigHandler(DWORD fdwCtrlType)
-{
- HANDLE hStdIn;
- /*
- * If Tcl is currently executing some bytecode or in the eventloop,
- * this will cause Tcl to enter asyncExit at the next command
- * boundry.
- */
- exitErrorCode = fdwCtrlType;
- Tcl_AsyncMark(exitToken);
-
- /*
- * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>
- * should it be blocked on input and our Tcl_AsyncMark didn't grab
- * the attention of the interpreter.
- */
- hStdIn = GetStdHandle(STD_INPUT_HANDLE);
- if (hStdIn) {
- CloseHandle(hStdIn);
- }
-
- /* indicate to the OS not to call the default terminator */
- return TRUE;
-}
+/*
+ * tclAppInit.c --
+ *
+ * Provides a default version of the main program and Tcl_AppInit
+ * procedure for Tcl applications (without Tk). Note that this
+ * program must be built in Win32 console mode to work properly.
+ *
+ * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclAppInit.c,v 1.13 2003/05/10 04:25:49 mistachkin Exp $
+ */
+
+#include "tcl.h"
+#include <windows.h>
+#include <locale.h>
+
+#ifdef TCL_TEST
+extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));
+extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#ifdef TCL_THREADS
+extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#endif
+#endif /* TCL_TEST */
+
+static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
+static BOOL __stdcall sigHandler (DWORD fdwCtrlType);
+static Tcl_AsyncProc asyncExit;
+static void AppInitExitHandler(ClientData clientData);
+
+static char ** argvSave = NULL;
+static Tcl_AsyncHandler exitToken = NULL;
+static DWORD exitErrorCode = 0;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * main --
+ *
+ * This is the main program for the application.
+ *
+ * Results:
+ * None: Tcl_Main never returns here, so this procedure never
+ * returns either.
+ *
+ * Side effects:
+ * Whatever the application does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+main(argc, argv)
+ int argc; /* Number of command-line arguments. */
+ char **argv; /* Values of command-line arguments. */
+{
+ /*
+ * The following #if block allows you to change the AppInit
+ * function by using a #define of TCL_LOCAL_APPINIT instead
+ * of rewriting this entire file. The #if checks for that
+ * #define and uses Tcl_AppInit if it doesn't exist.
+ */
+
+#ifndef TCL_LOCAL_APPINIT
+#define TCL_LOCAL_APPINIT Tcl_AppInit
+#endif
+ extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));
+
+ /*
+ * The following #if block allows you to change how Tcl finds the startup
+ * script, prime the library or encoding paths, fiddle with the argv,
+ * etc., without needing to rewrite Tcl_Main()
+ */
+
+#ifdef TCL_LOCAL_MAIN_HOOK
+ extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));
+#endif
+
+ char buffer[MAX_PATH +1];
+ char *p;
+ /*
+ * Set up the default locale to be standard "C" locale so parsing
+ * is performed correctly.
+ */
+
+ setlocale(LC_ALL, "C");
+ setargv(&argc, &argv);
+
+ /*
+ * Save this for later, so we can free it.
+ */
+ argvSave = argv;
+
+ /*
+ * Replace argv[0] with full pathname of executable, and forward
+ * slashes substituted for backslashes.
+ */
+
+ GetModuleFileName(NULL, buffer, sizeof(buffer));
+ argv[0] = buffer;
+ for (p = buffer; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+
+#ifdef TCL_LOCAL_MAIN_HOOK
+ TCL_LOCAL_MAIN_HOOK(&argc, &argv);
+#endif
+
+ Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
+
+ return 0; /* Needed only to prevent compiler warning. */
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppInit --
+ *
+ * This procedure performs application-specific initialization.
+ * Most applications, especially those that incorporate additional
+ * packages, will have their own version of this procedure.
+ *
+ * Results:
+ * Returns a standard Tcl completion code, and leaves an error
+ * message in the interp's result if an error occurs.
+ *
+ * Side effects:
+ * Depends on the startup script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AppInit(interp)
+ Tcl_Interp *interp; /* Interpreter for application. */
+{
+ if (Tcl_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Install a signal handler to the win32 console tclsh is running in.
+ */
+ SetConsoleCtrlHandler(sigHandler, TRUE);
+ exitToken = Tcl_AsyncCreate(asyncExit, NULL);
+
+ /*
+ * This exit handler will be used to free the
+ * resources allocated in this file.
+ */
+ Tcl_CreateExitHandler(AppInitExitHandler, NULL);
+
+#ifdef TCL_TEST
+ if (Tcltest_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
+ (Tcl_PackageInitProc *) NULL);
+ if (TclObjTest_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+#ifdef TCL_THREADS
+ if (TclThread_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+#endif
+ if (Procbodytest_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
+ Procbodytest_SafeInit);
+#endif /* TCL_TEST */
+
+#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES)
+ {
+ extern Tcl_PackageInitProc Registry_Init;
+ extern Tcl_PackageInitProc Dde_Init;
+
+ if (Registry_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ Tcl_StaticPackage(interp, "registry", Registry_Init, NULL);
+
+ if (Dde_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ Tcl_StaticPackage(interp, "dde", Dde_Init, NULL);
+ }
+#endif
+
+ /*
+ * Call the init procedures for included packages. Each call should
+ * look like this:
+ *
+ * if (Mod_Init(interp) == TCL_ERROR) {
+ * return TCL_ERROR;
+ * }
+ *
+ * where "Mod" is the name of the module.
+ */
+
+ /*
+ * Call Tcl_CreateCommand for application-specific commands, if
+ * they weren't already created by the init procedures called above.
+ */
+
+ /*
+ * Specify a user-specific startup file to invoke if the application
+ * is run interactively. Typically the startup file is "~/.apprc"
+ * where "app" is the name of the application. If this line is deleted
+ * then no user-specific startup file will be run under any conditions.
+ */
+
+ Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AppInitExitHandler --
+ *
+ * This function is called to cleanup the app init resources before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees the saved argv and deletes the async exit handler.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AppInitExitHandler(
+ ClientData clientData)
+{
+ if (argvSave != NULL) {
+ ckfree((char *)argvSave);
+ argvSave = NULL;
+ }
+
+ if (exitToken != NULL) {
+ /*
+ * This should be safe to do even if we
+ * are in an async exit right now.
+ */
+ Tcl_AsyncDelete(exitToken);
+ exitToken = NULL;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * setargv --
+ *
+ * Parse the Windows command line string into argc/argv. Done here
+ * because we don't trust the builtin argument parser in crt0.
+ * Windows applications are responsible for breaking their command
+ * line into arguments.
+ *
+ * 2N backslashes + quote -> N backslashes + begin quoted string
+ * 2N + 1 backslashes + quote -> literal
+ * N backslashes + non-quote -> literal
+ * quote + quote in a quoted string -> single quote
+ * quote + quote not in quoted string -> empty string
+ * quote -> begin quoted string
+ *
+ * Results:
+ * Fills argcPtr with the number of arguments and argvPtr with the
+ * array of arguments.
+ *
+ * Side effects:
+ * Memory allocated.
+ *
+ *--------------------------------------------------------------------------
+ */
+
+static void
+setargv(argcPtr, argvPtr)
+ int *argcPtr; /* Filled with number of argument strings. */
+ char ***argvPtr; /* Filled with argument strings (malloc'd). */
+{
+ char *cmdLine, *p, *arg, *argSpace;
+ char **argv;
+ int argc, size, inquote, copy, slashes;
+
+ cmdLine = GetCommandLine(); /* INTL: BUG */
+
+ /*
+ * Precompute an overly pessimistic guess at the number of arguments
+ * in the command line by counting non-space spans.
+ */
+
+ size = 2;
+ for (p = cmdLine; *p != '\0'; p++) {
+ if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
+ size++;
+ while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
+ p++;
+ }
+ if (*p == '\0') {
+ break;
+ }
+ }
+ }
+ argSpace = (char *) Tcl_Alloc(
+ (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
+ argv = (char **) argSpace;
+ argSpace += size * sizeof(char *);
+ size--;
+
+ p = cmdLine;
+ for (argc = 0; argc < size; argc++) {
+ argv[argc] = arg = argSpace;
+ while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
+ p++;
+ }
+ if (*p == '\0') {
+ break;
+ }
+
+ inquote = 0;
+ slashes = 0;
+ while (1) {
+ copy = 1;
+ while (*p == '\\') {
+ slashes++;
+ p++;
+ }
+ if (*p == '"') {
+ if ((slashes & 1) == 0) {
+ copy = 0;
+ if ((inquote) && (p[1] == '"')) {
+ p++;
+ copy = 1;
+ } else {
+ inquote = !inquote;
+ }
+ }
+ slashes >>= 1;
+ }
+
+ while (slashes) {
+ *arg = '\\';
+ arg++;
+ slashes--;
+ }
+
+ if ((*p == '\0')
+ || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
+ break;
+ }
+ if (copy != 0) {
+ *arg = *p;
+ arg++;
+ }
+ p++;
+ }
+ *arg = '\0';
+ argSpace = arg + 1;
+ }
+ argv[argc] = NULL;
+
+ *argcPtr = argc;
+ *argvPtr = argv;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * asyncExit --
+ *
+ * The AsyncProc for the exitToken.
+ *
+ * Results:
+ * doesn't actually return.
+ *
+ * Side effects:
+ * tclsh cleanly exits.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+asyncExit (ClientData clientData, Tcl_Interp *interp, int code)
+{
+ Tcl_Exit((int)exitErrorCode);
+
+ /* NOTREACHED */
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * sigHandler --
+ *
+ * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and
+ * other exits. This is needed so tclsh can do it's real clean-up
+ * and not an unclean crash terminate.
+ *
+ * Results:
+ * TRUE.
+ *
+ * Side effects:
+ * Effects the way the app exits from a signal. This is an
+ * operating system supplied thread and unsafe to call ANY
+ * Tcl commands except for Tcl_AsyncMark.
+ *
+ *----------------------------------------------------------------------
+ */
+
+BOOL __stdcall
+sigHandler(DWORD fdwCtrlType)
+{
+ HANDLE hStdIn;
+ /*
+ * If Tcl is currently executing some bytecode or in the eventloop,
+ * this will cause Tcl to enter asyncExit at the next command
+ * boundry.
+ */
+ exitErrorCode = fdwCtrlType;
+ Tcl_AsyncMark(exitToken);
+
+ /*
+ * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>
+ * should it be blocked on input and our Tcl_AsyncMark didn't grab
+ * the attention of the interpreter.
+ */
+ hStdIn = GetStdHandle(STD_INPUT_HANDLE);
+ if (hStdIn) {
+ CloseHandle(hStdIn);
+ }
+
+ /* indicate to the OS not to call the default terminator */
+ return TRUE;
+}
generated by cgit v0.12 at 2024-11-19 17:11:25 (GMT)