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:
+ */