path: root/generic/tclAlloc.c

/*
 * 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.
 */

#include "tclInt.h"
#include "tclAlloc.h"

/*
 * Parameters for the per-thread Tcl_Obj cache:
 *   - if >NOBJHIGH free objects, move some to the shared cache
 *   - if no objects are available, create NOBJALLOC of them
 */

#define NOBJHIGH	1200
#define NOBJALLOC	((NOBJHIGH*2)/3)


/*
 * The Tcl_Obj per-thread cache.
 */

typedef struct Cache {
    Tcl_Obj *firstObjPtr;	/* List of free objects for thread */
    int numObjects;		/* Number of objects for thread */
    void *allocCachePtr;
} Cache;

static Cache sharedCache;
#define sharedPtr (&sharedCache)

#if defined(TCL_THREADS)
static Tcl_Mutex *objLockPtr;

static Cache *	GetCache(void);
static void	MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove);

#if defined(HAVE_FAST_TSD)
static __thread Cache *tcachePtr;

# define GETCACHE(cachePtr)			\
    do {					\
	if (!tcachePtr) {			\
	    tcachePtr = GetCache();		\
	}					\
	(cachePtr) = tcachePtr;			\
    } while (0)

#else /* THREADS, not HAVE_FAST_TSD */
# define GETCACHE(cachePtr)			\
    do {					\
	(cachePtr) = TclpGetAllocCache();	\
	if ((cachePtr) == NULL) {		\
	    (cachePtr) = GetCache();		\
	}					\
    } while (0)
#endif /* FAST TSD */

#else /* NOT THREADS */
#define GETCACHE(cachePtr)			\
    (cachePtr) = (&sharedCache)
#endif /* THREADS */


/*
 *----------------------------------------------------------------------
 *
 * GetCache ---
 *
 *	Gets per-thread memory cache, allocating it if necessary.
 *
 * Results:
 *	Pointer to cache.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#if defined(TCL_THREADS)
static Cache *
GetCache(void)
{
    Cache *cachePtr;

    /*
     * Get this thread's cache, allocating if necessary.
     */

    cachePtr = TclpGetAllocCache();
    if (cachePtr == NULL) {
	cachePtr = calloc(1, sizeof(Cache));
	if (cachePtr == NULL) {
	    Tcl_Panic("alloc: could not allocate new cache");
	}
	cachePtr->allocCachePtr= NULL;
	TclpSetAllocCache(cachePtr);
    }
    return cachePtr;
}
#endif

/*
 * TclSetSharedAllocCache, TclSetAllocCache, TclGetAllocCache
 *
 * These are utility functions for the loadable allocator.
 */

void
TclSetSharedAllocCache(
    void *allocCachePtr)
{
    sharedPtr->allocCachePtr = allocCachePtr;
}

void
TclSetAllocCache(
    void *allocCachePtr)
{
    Cache *cachePtr;

    GETCACHE(cachePtr);
    cachePtr->allocCachePtr = allocCachePtr;
}

void *
TclGetAllocCache(void)
{
    Cache *cachePtr;

    GETCACHE(cachePtr);
    return cachePtr->allocCachePtr;
}

  
/*
 *-------------------------------------------------------------------------
 *
 * TclInitAlloc --
 *
 *	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;

    TCL_THREADED = 1;
    initLockPtr = Tcl_GetAllocMutex();
    Tcl_MutexLock(initLockPtr);
    objLockPtr = TclpNewAllocMutex();
    TclXpInitAlloc();
    Tcl_MutexUnlock(initLockPtr);
#else
    TCL_THREADED = 0;
    TclXpInitAlloc();
#endif /* THREADS */

#ifdef PURIFY
    TCL_PURIFY = 1;
#else
    TCL_PURIFY   = (getenv("TCL_PURIFY") != NULL);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeAlloc --
 *
 *	This procedure is used to destroy all private resources used in this
 *	file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *      Call the allocator-specific finalization.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeAlloc(void)
{
#if defined(TCL_THREADS)

    TclpFreeAllocMutex(objLockPtr);
    objLockPtr = NULL;

    TclpFreeAllocCache(NULL);
#endif
    TclXpFinalizeAlloc();
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreeAllocCache --
 *
 *	Flush and delete a cache, removing from list of caches.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#if defined(TCL_THREADS)
void
TclFreeAllocCache(
    void *arg)
{
    Cache *cachePtr = arg;
    
    /*
     * Flush objs.
     */

    if (cachePtr->numObjects > 0) {
	Tcl_MutexLock(objLockPtr);
	MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects);
	Tcl_MutexUnlock(objLockPtr);
    }

    /*
     * Flush the external allocator cache
     */

    TclXpFreeAllocCache(cachePtr->allocCachePtr);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclSmallAlloc --
 *
 *	Allocate a Tcl_Obj sized block from the per-thread cache.
 *
 * Results:
 *	Pointer to uninitialized memory.
 *
 * Side effects:
 *	May move blocks from shared cached or allocate new blocks if
 *	list is empty.
 *
 *----------------------------------------------------------------------
 */

void *
TclSmallAlloc(void)
{
    register Cache *cachePtr;
    register Tcl_Obj *objPtr;
    int numMove;
    Tcl_Obj *newObjsPtr;
   
    GETCACHE(cachePtr);

    /*
     * Pop the first object.
     */

    if(cachePtr->firstObjPtr) {
	haveObj:
	objPtr = cachePtr->firstObjPtr;
	cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
	cachePtr->numObjects--;
	return objPtr;
    }

    /*
     * Do it AFTER looking at the queue, so that it doesn't slow down
     * non-purify small allocs.
     */
    
    if (TCL_PURIFY) {
	Tcl_Obj *objPtr = (Tcl_Obj *) TclpAlloc(sizeof(Tcl_Obj));
	if (objPtr == NULL) {
	    Tcl_Panic("alloc: could not allocate a new object");
	}
	return objPtr;
    }
    
    /*
     * Get this thread's obj list structure and move or allocate new objs if
     * necessary.
     */

#if defined(TCL_THREADS)
    Tcl_MutexLock(objLockPtr);
    numMove = sharedPtr->numObjects;
    if (numMove > 0) {
	if (numMove > NOBJALLOC) {
	    numMove = NOBJALLOC;
	}
	MoveObjs(sharedPtr, cachePtr, numMove);
    }
    Tcl_MutexUnlock(objLockPtr);
    if (cachePtr->firstObjPtr) {
	goto haveObj;
    }
#endif	
    cachePtr->numObjects = numMove = NOBJALLOC;
    newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove);
    if (newObjsPtr == NULL) {
	Tcl_Panic("alloc: could not allocate %d new objects", numMove);
    }
    while (--numMove >= 0) {
	objPtr = &newObjsPtr[numMove];
	objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
	cachePtr->firstObjPtr = objPtr;
    }
    goto haveObj;
}


/*
 *----------------------------------------------------------------------
 *
 * TclSmallFree --
 *
 *	Return a free Tcl_Obj-sized block to the per-thread cache.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May move free blocks to shared list upon hitting high water mark.
 *
 *----------------------------------------------------------------------
 */

void
TclSmallFree(
    void *ptr)
{
    Cache *cachePtr;
    Tcl_Obj *objPtr = ptr;
    
    if (TCL_PURIFY) {
	TclpFree((char *) ptr);
	return;
    }
    
    GETCACHE(cachePtr);

    /*
     * Get this thread's list and push on the free Tcl_Obj.
     */

    objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
    cachePtr->firstObjPtr = objPtr;
    cachePtr->numObjects++;

#if defined(TCL_THREADS)
    /*
     * If the number of free objects has exceeded the high water mark, move
     * some blocks to the shared list.
     */

    if (cachePtr->numObjects > NOBJHIGH) {
	Tcl_MutexLock(objLockPtr);
	MoveObjs(cachePtr, sharedPtr, NOBJALLOC);
	Tcl_MutexUnlock(objLockPtr);
    }
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * MoveObjs --
 *
 *	Move Tcl_Obj's between caches.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	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

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */