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 Tcl_HashTable* refTable;




TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */



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

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

 */

void
Tcl_Preserve(
    ClientData clientData)	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    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);






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



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

	refPtr = Tcl_GetHashValue (hEntry);
	refPtr->refCount++;




	Tcl_MutexUnlock(&preserveMutex);
	return;
    }

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

    refPtr = ckalloc (sizeof (Reference));
    refPtr->clientData = clientData;
    refPtr->refCount = 1;
    refPtr->mustFree = 0;
    refPtr->freeProc = TCL_STATIC;

    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 mustFree;
    Tcl_FreeProc *freeProc;

    Tcl_MutexLock(&preserveMutex);

    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.

     */

    freeProc = refPtr->freeProc;
    mustFree = refPtr->mustFree;




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

    Tcl_MutexUnlock(&preserveMutex);

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








}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EventuallyFree --
 *

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


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

    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) {