diff options
Diffstat (limited to 'generic/tclObjAlloc.c')
-rw-r--r-- | generic/tclObjAlloc.c | 442 |
1 files changed, 442 insertions, 0 deletions
diff --git a/generic/tclObjAlloc.c b/generic/tclObjAlloc.c new file mode 100644 index 0000000..08900e8 --- /dev/null +++ b/generic/tclObjAlloc.c @@ -0,0 +1,442 @@ +/* + * tclAlloc.c -- + * + * This is the generic part of the Tcl allocator. It handles the + * freeObjLists and defines which main allocator will be used. + * + * Copyright (c) 2013 by Miguel Sofer. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef PURIFY + +#include "tclInt.h" + +static int purify = 0; + +/* + * Parameters for the per-thread Tcl_Obj cache: + * - if >NOBJHIGH free objects, move some to the shared cache + * - if no objects are available, create NOBJALLOC of them + */ + +#define NOBJHIGH 1200 +#define NOBJALLOC ((NOBJHIGH*2)/3) + + +/* + * The Tcl_Obj per-thread cache. + */ + +typedef struct Cache { + Tcl_Obj *firstObjPtr; /* List of free objects for thread */ + int numObjects; /* Number of objects for thread */ + void *allocCachePtr; +} Cache; + +static Cache sharedCache; +#define sharedPtr (&sharedCache) + +#if defined(TCL_THREADS) +static Tcl_Mutex *objLockPtr; + +static Cache * GetCache(void); +static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); + +#if defined(HAVE_FAST_TSD) +static __thread Cache *tcachePtr; + +# define GETCACHE(cachePtr) \ + do { \ + if (!tcachePtr) { \ + tcachePtr = GetCache(); \ + } \ + (cachePtr) = tcachePtr; \ + } while (0) + +#else /* THREADS, not HAVE_FAST_TSD */ +# define GETCACHE(cachePtr) \ + do { \ + (cachePtr) = TclpGetAllocCache(); \ + if ((cachePtr) == NULL) { \ + (cachePtr) = GetCache(); \ + } \ + } while (0) +#endif /* FAST TSD */ + +#else /* NOT THREADS */ +#define GETCACHE(cachePtr) \ + (cachePtr) = (&sharedCache) +#endif /* THREADS */ + + +/* + *---------------------------------------------------------------------- + * + * GetCache --- + * + * Gets per-thread memory cache, allocating it if necessary. + * + * Results: + * Pointer to cache. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +static Cache * +GetCache(void) +{ + Cache *cachePtr; + + /* + * Get this thread's cache, allocating if necessary. + */ + + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = calloc(1, sizeof(Cache)); + if (cachePtr == NULL) { + Tcl_Panic("alloc: could not allocate new cache"); + } + cachePtr->allocCachePtr= NULL; + TclpSetAllocCache(cachePtr); + } + return cachePtr; +} +#endif + +/* + * TclSetSharedAllocCache, TclSetAllocCache, TclGetAllocCache + * + * These are utility functions for the loadable allocator. + */ + +void +TclSetSharedAllocCache( + void *allocCachePtr) +{ + sharedPtr->allocCachePtr = allocCachePtr; +} + +void +TclSetAllocCache( + void *allocCachePtr) +{ + Cache *cachePtr; + + GETCACHE(cachePtr); + cachePtr->allocCachePtr = allocCachePtr; +} + +void * +TclGetAllocCache(void) +{ + Cache *cachePtr; + + GETCACHE(cachePtr); + return cachePtr->allocCachePtr; +} + + +/* + *------------------------------------------------------------------------- + * + * TclInitAlloc -- + * + * Initialize the memory system. + * + * Results: + * None. + * + * Side effects: + * Initialize the mutex used to serialize obj allocations. + * Call the allocator-specific initialization. + * + *------------------------------------------------------------------------- + */ + +void +TclInitAlloc(void) +{ + /* + * Set the params for the correct allocator + */ + +#if defined(TCL_THREADS) + Tcl_Mutex *initLockPtr; + + initLockPtr = Tcl_GetAllocMutex(); + Tcl_MutexLock(initLockPtr); + objLockPtr = TclpNewAllocMutex(); + Tcl_MutexUnlock(initLockPtr); +#endif + + /* Make it possible to switch to purify mode without recompiling */ + purify = (getenv("TCL_PURIFY") != NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAlloc -- + * + * This procedure is used to destroy all private resources used in this + * file. + * + * Results: + * None. + * + * Side effects: + * Call the allocator-specific finalization. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAlloc(void) +{ +#if defined(TCL_THREADS) + + TclpFreeAllocMutex(objLockPtr); + objLockPtr = NULL; + + TclpFreeAllocCache(NULL); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclFreeAllocCache -- + * + * Flush and delete a cache, removing from list of caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +void +TclFreeAllocCache( + void *arg) +{ + Cache *cachePtr = arg; + + /* + * Flush objs. + */ + + if (cachePtr->numObjects > 0) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); + Tcl_MutexUnlock(objLockPtr); + } +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclSmallAlloc -- + * + * Allocate a Tcl_Obj sized block from the per-thread cache. + * + * Results: + * Pointer to uninitialized memory. + * + * Side effects: + * May move blocks from shared cached or allocate new blocks if + * list is empty. + * + *---------------------------------------------------------------------- + */ + +void * +TclSmallAlloc(void) +{ + register Cache *cachePtr; + register Tcl_Obj *objPtr; + int numMove; + Tcl_Obj *newObjsPtr; + + GETCACHE(cachePtr); + + /* + * Pop the first object. + */ + + if(cachePtr->firstObjPtr) { + haveObj: + objPtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + cachePtr->numObjects--; + return objPtr; + } + + /* + * Do it AFTER looking at the queue, so that it doesn't slow down + * non-purify small allocs. + */ + + if (purify) { + Tcl_Obj *objPtr = (Tcl_Obj *) TclpAlloc(sizeof(Tcl_Obj)); + if (objPtr == NULL) { + Tcl_Panic("alloc: could not allocate a new object"); + } + return objPtr; + } + + /* + * Get this thread's obj list structure and move or allocate new objs if + * necessary. + */ + +#if defined(TCL_THREADS) + Tcl_MutexLock(objLockPtr); + numMove = sharedPtr->numObjects; + if (numMove > 0) { + if (numMove > NOBJALLOC) { + numMove = NOBJALLOC; + } + MoveObjs(sharedPtr, cachePtr, numMove); + } + Tcl_MutexUnlock(objLockPtr); + if (cachePtr->firstObjPtr) { + goto haveObj; + } +#endif + cachePtr->numObjects = numMove = NOBJALLOC; + newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + if (newObjsPtr == NULL) { + Tcl_Panic("alloc: could not allocate %d new objects", numMove); + } + while (--numMove >= 0) { + objPtr = &newObjsPtr[numMove]; + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + } + goto haveObj; +} + + +/* + *---------------------------------------------------------------------- + * + * TclSmallFree -- + * + * Return a free Tcl_Obj-sized block to the per-thread cache. + * + * Results: + * None. + * + * Side effects: + * May move free blocks to shared list upon hitting high water mark. + * + *---------------------------------------------------------------------- + */ + +void +TclSmallFree( + void *ptr) +{ + Cache *cachePtr; + Tcl_Obj *objPtr = ptr; + + if (purify) { + TclpFree((char *) ptr); + return; + } + + GETCACHE(cachePtr); + + /* + * Get this thread's list and push on the free Tcl_Obj. + */ + + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + cachePtr->numObjects++; + +#if defined(TCL_THREADS) + /* + * If the number of free objects has exceeded the high water mark, move + * some blocks to the shared list. + */ + + if (cachePtr->numObjects > NOBJHIGH) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, NOBJALLOC); + Tcl_MutexUnlock(objLockPtr); + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * MoveObjs -- + * + * Move Tcl_Obj's between caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +static void +MoveObjs( + Cache *fromPtr, + Cache *toPtr, + int numMove) +{ + register Tcl_Obj *objPtr = fromPtr->firstObjPtr; + Tcl_Obj *fromFirstObjPtr = objPtr; + + toPtr->numObjects += numMove; + fromPtr->numObjects -= numMove; + + /* + * Find the last object to be moved; set the next one (the first one not + * to be moved) as the first object in the 'from' cache. + */ + + while (--numMove) { + objPtr = objPtr->internalRep.otherValuePtr; + } + fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + + /* + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. + */ + + objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + toPtr->firstObjPtr = fromFirstObjPtr; +} +#endif + +#endif /* PURIFY */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |