Tcl Source Code

/*
 * tclPreserve.c --
 *
 *	This file contains a collection of functions that are used to make
 *	sure that widget records and other data structures aren't reallocated
 *	when there are nested functions that depend on their existence.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *
 * === NOVEM EXPERIMENT ===
 *   Replace the dynamic var-sized array of References with a
 *   hashtable. Faster lookup, no linear search.
 *
 *   Current disadvantage - Possible higher memory churn as individual
 *   Reference structures get allocated and freed.
 *
 *   Could be fixable by using a list-based stack of free/reusable Reference
 *   structures.
 * === NOVEM EXPERIMENT ===
 */

#include "tclInt.h"

/*
 * The following data structure is used to keep track of all the Tcl_Preserve
 * calls that are still in effect. It grows as needed to accommodate any

} Reference;

/*
 * Global data structures used to hold the list of preserved data references.
 * These variables are protected by "preserveMutex".
 */

static Reference *refArray = NULL;	/* First in array of references. */
static int spaceAvl = 0;	/* Total number of structures available at
static Tcl_HashTable* refTable;

				 * *firstRefPtr. */
static int inUse = 0;		/* Count of structures currently in use in
				 * refArray. */
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */

#define INITIAL_SIZE	2	/* Initial number of reference slots to make */

/*
 * The following data structure is used to keep track of whether an arbitrary
 * block of memory has been deleted. This is used by the TclHandle code to
 * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism
 * is mainly used when we have lots of references to a few big, expensive
 * objects that we don't want to live any longer than necessary.

 */

	/* ARGSUSED */
void
TclFinalizePreserve(void)
{
    Tcl_MutexLock(&preserveMutex);
    if (spaceAvl != 0) {
	ckfree(refArray);
	refArray = NULL;
	inUse = 0;
    if (refTable) {
	for (;;) {
	    Reference* refPtr;
	    Tcl_HashSearch s;
	    Tcl_HashEntry* hEntry;
	    hEntry = Tcl_FirstHashEntry (refTable, &s);
	    if (!hEntry) break;
	    refPtr = Tcl_GetHashValue (hEntry);
	    Tcl_DeleteHashEntry (hEntry);
	    ckfree (refPtr);
	}
	Tcl_DeleteHashTable (refTable);
	refTable = 0;
	spaceAvl = 0;
    }
    Tcl_MutexUnlock(&preserveMutex);
}

/*
 *----------------------------------------------------------------------
 *

 */

void
Tcl_Preserve(
    ClientData clientData)	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    int i;
    int isnew;
    Tcl_HashEntry* hEntry;

    /*
     * See if there is already a reference for this pointer. If so, just
     * increment its reference count.
     */

    Tcl_MutexLock(&preserveMutex);
    for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
	if (refPtr->clientData == clientData) {
	    refPtr->refCount++;
	    Tcl_MutexUnlock(&preserveMutex);
	    return;
	}

    if (!refTable) {
	refTable = ckalloc (sizeof (Tcl_HashTable));
	Tcl_InitHashTable (refTable, TCL_ONE_WORD_KEYS);
    }

    /*
     * Make a reference array if it doesn't already exist, or make it bigger
     * if it is full.
    hEntry = Tcl_FindHashEntry (refTable, clientData);
    if (hEntry) {
     */
	refPtr = Tcl_GetHashValue (hEntry);
	refPtr->refCount++;

    if (inUse == spaceAvl) {
	spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
	refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference));
	Tcl_MutexUnlock(&preserveMutex);
	return;
    }

    /*
     * Make a new entry for the new reference.
     */

    refPtr = &refArray[inUse];
    refPtr = ckalloc (sizeof (Reference));
    refPtr->clientData = clientData;
    refPtr->refCount = 1;
    refPtr->mustFree = 0;
    refPtr->freeProc = TCL_STATIC;
    inUse += 1;

    hEntry = Tcl_CreateHashEntry (refTable, clientData, &isnew);
    Tcl_SetHashValue (hEntry, refPtr);

    Tcl_MutexUnlock(&preserveMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Release --

 */

void
Tcl_Release(
    ClientData clientData)	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    Tcl_HashEntry* hEntry;
    int i;
    int mustFree;
    Tcl_FreeProc *freeProc;

    Tcl_MutexLock(&preserveMutex);
    for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
	int mustFree;
	Tcl_FreeProc *freeProc;

	if (refPtr->clientData != clientData) {
	    continue;
	}

	if (--refPtr->refCount != 0) {
	    Tcl_MutexUnlock(&preserveMutex);
	    return;
	}

    if (!refTable) {
	refTable = ckalloc (sizeof (Tcl_HashTable));
	Tcl_InitHashTable (refTable, TCL_ONE_WORD_KEYS);
    }

    hEntry = Tcl_FindHashEntry (refTable, clientData);
    if (!hEntry) {
	Tcl_MutexUnlock(&preserveMutex);

	/*
	 * Reference not found. This is a bug in the caller.
	 */

	Tcl_Panic("Tcl_Release couldn't find reference for %p", clientData);
    }

    refPtr = Tcl_GetHashValue (hEntry);

    if (--refPtr->refCount != 0) {
	Tcl_MutexUnlock(&preserveMutex);
	return;
    }

	/*
	 * Must remove information from the slot before calling freeProc to
	 * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the
	 * same clientData. Copy down the last reference in the array to
    /*
     * Must remove information from the slot before calling freeProc to
     * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the
     * same clientData.
	 * overwrite the current slot.
	 */
     */

	freeProc = refPtr->freeProc;
	mustFree = refPtr->mustFree;
    freeProc = refPtr->freeProc;
    mustFree = refPtr->mustFree;
	inUse--;
	if (i < inUse) {
	    refArray[i] = refArray[inUse];
	}

    Tcl_DeleteHashEntry (hEntry);
    ckfree (refPtr);

	/*
	 * Now committed to disposing the data. But first, we've patched up
	 * all the global data structures so we should release the mutex now.
	 * Only then should we dabble around with potentially-slow memory
	 * managers...
	 */
    /*
     * Now committed to disposing the data. But first, we've patched up
     * all the global data structures so we should release the mutex now.
     * Only then should we dabble around with potentially-slow memory
     * managers...
     */

	Tcl_MutexUnlock(&preserveMutex);
	if (mustFree) {
	    if (freeProc == TCL_DYNAMIC) {
		ckfree(clientData);
	    } else {
		freeProc(clientData);
	    }
	}
	return;
    Tcl_MutexUnlock(&preserveMutex);

    if (mustFree) {
	if (freeProc == TCL_DYNAMIC) {
	    ckfree(clientData);
	} else {
	    freeProc(clientData);
	}
    }
    return;
    }
    Tcl_MutexUnlock(&preserveMutex);

    /*
     * Reference not found. This is a bug in the caller.
     */

    Tcl_Panic("Tcl_Release couldn't find reference for %p", clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EventuallyFree --
 *

void
Tcl_EventuallyFree(
    ClientData clientData,	/* Pointer to malloc'ed block of memory. */
    Tcl_FreeProc *freeProc)	/* Function to actually do free. */
{
    Reference *refPtr;
    int i;

    /*
     * See if there is a reference for this pointer. If so, set its "mustFree"
     * flag (the flag had better not be set already!).
     */

    Tcl_MutexLock(&preserveMutex);
    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
	if (refPtr->clientData != clientData) {
	    continue;
	}
	if (refPtr->mustFree) {
	    Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData);
	}
	refPtr->mustFree = 1;
	refPtr->freeProc = freeProc;
	Tcl_MutexUnlock(&preserveMutex);
	return;
    }

    if (refTable) {
	Tcl_HashEntry* hEntry;

	hEntry = Tcl_FindHashEntry (refTable, clientData);
	if (hEntry) {
	    refPtr = Tcl_GetHashValue (hEntry);

	    if (refPtr->mustFree) {
		Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData);
	    }
	    refPtr->mustFree = 1;
	    refPtr->freeProc = freeProc;

	    Tcl_MutexUnlock(&preserveMutex);
	    return;
	}
    }

    Tcl_MutexUnlock(&preserveMutex);

    /*
     * No reference for this block.  Free it now.
     */

    if (freeProc == TCL_DYNAMIC) {