path: root/generic/tclLiteral.c

/*
 * tclLiteral.c --
 *
 *	Implementation of the global and ByteCode-local literal tables used to
 *	manage the Tcl objects created for literal values during compilation
 *	of Tcl scripts. This implementation borrows heavily from the more
 *	general hashtable implementation of Tcl hash tables that appears in
 *	tclHash.c.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Kevin B. Kenny.  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 "tclCompile.h"

/*
 * When there are this many entries per bucket, on average, rebuild a
 * literal's hash table to make it larger.
 */

#define REBUILD_MULTIPLIER	3

/*
 * Function prototypes for static functions in this file:
 */

static int		AddLocalLiteralEntry(CompileEnv *envPtr,
			    Tcl_Obj *objPtr, int localHash);
static void		ExpandLocalLiteralArray(CompileEnv *envPtr);
static unsigned		HashString(const char *string, int length);
#ifdef TCL_COMPILE_DEBUG
static LiteralEntry *	LookupLiteralEntry(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
#endif
static void		RebuildLiteralTable(LiteralTable *tablePtr);

/*
 *----------------------------------------------------------------------
 *
 * TclInitLiteralTable --
 *
 *	This function is called to initialize the fields of a literal table
 *	structure for either an interpreter or a compilation's CompileEnv
 *	structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The literal table is made ready for use.
 *
 *----------------------------------------------------------------------
 */

void
TclInitLiteralTable(
    register LiteralTable *tablePtr)
				/* Pointer to table structure, which is
				 * supplied by the caller. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
    Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable",
	    TCL_SMALL_HASH_TABLE);
#endif

    tablePtr->buckets = tablePtr->staticBuckets;
    tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
    tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
    tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
    tablePtr->numEntries = 0;
    tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE * REBUILD_MULTIPLIER;
    tablePtr->mask = 3;
}

/*
 *----------------------------------------------------------------------
 *
 * TclDeleteLiteralTable --
 *
 *	This function frees up everything associated with a literal table
 *	except for the table's structure itself. It is called when the
 *	interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Each literal in the table is released: i.e., its reference count in
 *	the global literal table is decremented and, if it becomes zero, the
 *	literal is freed. In addition, the table's bucket array is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteLiteralTable(
    Tcl_Interp *interp,		/* Interpreter containing shared literals
				 * referenced by the table to delete. */
    LiteralTable *tablePtr)	/* Points to the literal table to delete. */
{
    LiteralEntry *entryPtr, *nextPtr;
    Tcl_Obj *objPtr;
    int i;

    /*
     * Release remaining literals in the table. Note that releasing a literal
     * might release other literals, modifying the table, so we restart the
     * search from the bucket chain we last found an entry.
     */

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable((Interp *) interp);
#endif /*TCL_COMPILE_DEBUG*/

    /*
     * We used to call TclReleaseLiteral for each literal in the table, which
     * is rather inefficient as it causes one lookup-by-hash for each
     * reference to the literal. We now rely at interp-deletion on each
     * bytecode object to release its references to the literal Tcl_Obj
     * without requiring that it updates the global table itself, and deal
     * here only with the table.
     */

    for (i=0 ; i<tablePtr->numBuckets ; i++) {
	entryPtr = tablePtr->buckets[i];
	while (entryPtr != NULL) {
	    objPtr = entryPtr->objPtr;
	    TclDecrRefCount(objPtr);
	    nextPtr = entryPtr->nextPtr;
	    ckfree(entryPtr);
	    entryPtr = nextPtr;
	}
    }

    /*
     * Free up the table's bucket array if it was dynamically allocated.
     */

    if (tablePtr->buckets != tablePtr->staticBuckets) {
	ckfree(tablePtr->buckets);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateLiteral --
 *
 *	Find, or if necessary create, an object in the interpreter's literal
 *	table that has a string representation matching the argument
 *	string. If nsPtr!=NULL then only literals stored for the namespace are
 *	considered.
 *
 * Results:
 *	The literal object. If it was created in this call *newPtr is set to
 *	1, else 0. NULL is returned if newPtr==NULL and no literal is found.
 *
 * Side effects:
 *	Increments the ref count of the global LiteralEntry since the caller
 *	now holds a reference. If LITERAL_ON_HEAP is set in flags, this
 *	function is given ownership of the string: if an object is created
 *	then its string representation is set directly from string, otherwise
 *	the string is freed. Typically, a caller sets LITERAL_ON_HEAP if
 *	"string" is an already heap-allocated buffer holding the result of
 *	backslash substitutions.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclCreateLiteral(
    Interp *iPtr,
    char *bytes,		/* The start of the string. Note that this is
				 * not a NUL-terminated string. */
    int length,			/* Number of bytes in the string. */
    unsigned hash,		/* The string's hash. If -1, it will be
				 * computed here. */
    int *newPtr,
    Namespace *nsPtr,
    int flags,
    LiteralEntry **globalPtrPtr)
{
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    LiteralEntry *globalPtr;
    int globalHash;
    Tcl_Obj *objPtr;

    /*
     * Is it in the interpreter's global literal table?
     */

    if (hash == (unsigned) -1) {
	hash = HashString(bytes, length);
    }
    globalHash = (hash & globalTablePtr->mask);
    for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL;
	    globalPtr = globalPtr->nextPtr) {
	objPtr = globalPtr->objPtr;
	if ((globalPtr->nsPtr == nsPtr)
		&& (objPtr->length == length) && ((length == 0)
		|| ((objPtr->bytes[0] == bytes[0])
		&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
	    /*
	     * A literal was found: return it
	     */

	    if (newPtr) {
		*newPtr = 0;
	    }
	    if (globalPtrPtr) {
		*globalPtrPtr = globalPtr;
	    }
	    if (flags & LITERAL_ON_HEAP) {
		ckfree(bytes);
	    }
	    globalPtr->refCount++;
	    return objPtr;
	}
    }
    if (!newPtr) {
	if (flags & LITERAL_ON_HEAP) {
	    ckfree(bytes);
	}
	return NULL;
    }

    /*
     * The literal is new to the interpreter. Add it to the global literal
     * table.
     */

    TclNewObj(objPtr);
    Tcl_IncrRefCount(objPtr);
    if (flags & LITERAL_ON_HEAP) {
	objPtr->bytes = bytes;
	objPtr->length = length;
    } else {
	TclInitStringRep(objPtr, bytes, length);
    }

#ifdef TCL_COMPILE_DEBUG
    if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
	Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
		"TclRegisterLiteral", (length>60? 60 : length), bytes);
    }
#endif

    globalPtr = ckalloc(sizeof(LiteralEntry));
    globalPtr->objPtr = objPtr;
    globalPtr->refCount = 1;
    globalPtr->nsPtr = nsPtr;
    globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
    globalTablePtr->buckets[globalHash] = globalPtr;
    globalTablePtr->numEntries++;

    /*
     * If the global literal table has exceeded a decent size, rebuild it with
     * more buckets.
     */

    if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
	RebuildLiteralTable(globalTablePtr);
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable(iPtr);
    {
	LiteralEntry *entryPtr;
	int found, i;

	found = 0;
	for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
	    for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ;
		    entryPtr=entryPtr->nextPtr) {
		if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) {
		    found = 1;
		}
	    }
	}
	if (!found) {
	    Tcl_Panic("%s: literal \"%.*s\" wasn't global",
		    "TclRegisterLiteral", (length>60? 60 : length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numLiteralsCreated++;
    iPtr->stats.totalLitStringBytes += (double) (length + 1);
    iPtr->stats.currentLitStringBytes += (double) (length + 1);
    iPtr->stats.literalCount[TclLog2(length)]++;
#endif /*TCL_COMPILE_STATS*/

    if (globalPtrPtr) {
	*globalPtrPtr = globalPtr;
    }
    *newPtr = 1;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclRegisterLiteral --
 *
 *	Find, or if necessary create, an object in a CompileEnv literal array
 *	that has a string representation matching the argument string.
 *
 * Results:
 *	The index in the CompileEnv's literal array that references a shared
 *	literal matching the string. The object is created if necessary.
 *
 * Side effects:
 *	To maximize sharing, we look up the string in the interpreter's global
 *	literal table. If not found, we create a new shared literal in the
 *	global table. We then add a reference to the shared literal in the
 *	CompileEnv's literal array.
 *
 *	If LITERAL_ON_HEAP is set in flags, this function is given ownership
 *	of the string: if an object is created then its string representation
 *	is set directly from string, otherwise the string is freed. Typically,
 *	a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
 *	buffer holding the result of backslash substitutions.
 *
 *----------------------------------------------------------------------
 */

int
TclRegisterLiteral(
    CompileEnv *envPtr,		/* Points to the CompileEnv in whose object
				 * array an object is found or created. */
    register char *bytes,	/* Points to string for which to find or
				 * create an object in CompileEnv's object
				 * array. */
    int length,			/* Number of bytes in the string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    int flags)			/* If LITERAL_ON_HEAP then the caller already
				 * malloc'd bytes and ownership is passed to
				 * this function. If LITERAL_CMD_NAME then
				 * the literal should not be shared accross
				 * namespaces. */
{
    Interp *iPtr = envPtr->iPtr;
    LiteralTable *localTablePtr = &envPtr->localLitTable;
    LiteralEntry *globalPtr, *localPtr;
    Tcl_Obj *objPtr;
    unsigned hash;
    int localHash, objIndex, new;
    Namespace *nsPtr;

    if (length < 0) {
	length = (bytes ? strlen(bytes) : 0);
    }
    hash = HashString(bytes, length);

    /*
     * Is the literal already in the CompileEnv's local literal array? If so,
     * just return its index.
     */

    localHash = (hash & localTablePtr->mask);
    for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL;
	    localPtr = localPtr->nextPtr) {
	objPtr = localPtr->objPtr;
	if ((objPtr->length == length) && ((length == 0)
		|| ((objPtr->bytes[0] == bytes[0])
		&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
	    if (flags & LITERAL_ON_HEAP) {
		ckfree(bytes);
	    }
	    objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
	    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/

	    return objIndex;
	}
    }

    /*
     * The literal is new to this CompileEnv. If it is a command name, avoid
     * sharing it accross namespaces, and try not to share it with non-cmd
     * literals. Note that FQ command names can be shared, so that we register
     * the namespace as the interp's global NS.
     */

    if (flags & LITERAL_CMD_NAME) {
	if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
	    nsPtr = iPtr->globalNsPtr;
	} else {
	    nsPtr = iPtr->varFramePtr->nsPtr;
	}
    } else {
	nsPtr = NULL;
    }
    
    /*
     * Is it in the interpreter's global literal table? If not, create it.
     */

    objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
	    &globalPtr);
    objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);

#ifdef TCL_COMPILE_DEBUG
    if (globalPtr->refCount < 1) {
	Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
		"TclRegisterLiteral", (length>60? 60 : length), bytes,
		globalPtr->refCount);
    }
    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
    return objIndex;
}

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * LookupLiteralEntry --
 *
 *	Finds the LiteralEntry that corresponds to a literal Tcl object
 *	holding a literal.
 *
 * Results:
 *	Returns the matching LiteralEntry if found, otherwise NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static LiteralEntry *
LookupLiteralEntry(
    Tcl_Interp *interp,		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register Tcl_Obj *objPtr)	/* Points to a Tcl object holding a literal
				 * that was previously created by a call to
				 * TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    register LiteralEntry *entryPtr;
    const char *bytes;
    int length, globalHash;

    bytes = TclGetStringFromObj(objPtr, &length);
    globalHash = (HashString(bytes, length) & globalTablePtr->mask);
    for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL;
	    entryPtr=entryPtr->nextPtr) {
	if (entryPtr->objPtr == objPtr) {
	    return entryPtr;
	}
    }
    return NULL;
}

#endif
/*
 *----------------------------------------------------------------------
 *
 * TclHideLiteral --
 *
 *	Remove a literal entry from the literal hash tables, leaving it in the
 *	literal array so existing references continue to function. This makes
 *	it possible to turn a shared literal into a private literal that
 *	cannot be shared.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the literal from the local hash table and decrements the
 *	global hash entry's reference count.
 *
 *----------------------------------------------------------------------
 */

void
TclHideLiteral(
    Tcl_Interp *interp,		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register CompileEnv *envPtr,/* Points to CompileEnv whose literal array
				 * contains the entry being hidden. */
    int index)			/* The index of the entry in the literal
				 * array. */
{
    LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
    LiteralTable *localTablePtr = &envPtr->localLitTable;
    int localHash, length;
    const char *bytes;
    Tcl_Obj *newObjPtr;

    lPtr = &envPtr->literalArrayPtr[index];

    /*
     * To avoid unwanted sharing we need to copy the object and remove it from
     * the local and global literal tables. It still has a slot in the literal
     * array so it can be referred to by byte codes, but it will not be
     * matched by literal searches.
     */

    newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
    Tcl_IncrRefCount(newObjPtr);
    TclReleaseLiteral(interp, lPtr->objPtr);
    lPtr->objPtr = newObjPtr;

    bytes = TclGetStringFromObj(newObjPtr, &length);
    localHash = (HashString(bytes, length) & localTablePtr->mask);
    nextPtrPtr = &localTablePtr->buckets[localHash];

    for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
	if (entryPtr == lPtr) {
	    *nextPtrPtr = lPtr->nextPtr;
	    lPtr->nextPtr = NULL;
	    localTablePtr->numEntries--;
	    break;
	}
	nextPtrPtr = &entryPtr->nextPtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclAddLiteralObj --
 *
 *	Add a single literal object to the literal array. This function does
 *	not add the literal to the local or global literal tables. The caller
 *	is expected to add the entry to whatever tables are appropriate.
 *
 * Results:
 *	The index in the CompileEnv's literal array that references the
 *	literal. Stores the pointer to the new literal entry in the location
 *	referenced by the localPtrPtr argument.
 *
 * Side effects:
 *	Expands the literal array if necessary. Increments the refcount on the
 *	literal object.
 *
 *----------------------------------------------------------------------
 */

int
TclAddLiteralObj(
    register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
				 * the object is to be inserted. */
    Tcl_Obj *objPtr,		/* The object to insert into the array. */
    LiteralEntry **litPtrPtr)	/* The location where the pointer to the new
				 * literal entry should be stored. May be
				 * NULL. */
{
    register LiteralEntry *lPtr;
    int objIndex;

    if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
	ExpandLocalLiteralArray(envPtr);
    }
    objIndex = envPtr->literalArrayNext;
    envPtr->literalArrayNext++;

    lPtr = &envPtr->literalArrayPtr[objIndex];
    lPtr->objPtr = objPtr;
    Tcl_IncrRefCount(objPtr);
    lPtr->refCount = -1;	/* i.e., unused */
    lPtr->nextPtr = NULL;

    if (litPtrPtr) {
	*litPtrPtr = lPtr;
    }

    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * AddLocalLiteralEntry --
 *
 *	Insert a new literal into a CompileEnv's local literal array.
 *
 * Results:
 *	The index in the CompileEnv's literal array that references the
 *	literal.
 *
 * Side effects:
 *	Expands the literal array if necessary. May rebuild the hash bucket
 *	array of the CompileEnv's literal array if it becomes too large.
 *
 *----------------------------------------------------------------------
 */

static int
AddLocalLiteralEntry(
    register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
				 * the object is to be inserted. */
    Tcl_Obj *objPtr,		/* The literal to add to the CompileEnv. */
    int localHash)		/* Hash value for the literal's string. */
{
    register LiteralTable *localTablePtr = &envPtr->localLitTable;
    LiteralEntry *localPtr;
    int objIndex;

    objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr);

    /*
     * Add the literal to the local table.
     */

    localPtr->nextPtr = localTablePtr->buckets[localHash];
    localTablePtr->buckets[localHash] = localPtr;
    localTablePtr->numEntries++;

    /*
     * If the CompileEnv's local literal table has exceeded a decent size,
     * rebuild it with more buckets.
     */

    if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
	RebuildLiteralTable(localTablePtr);
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(envPtr);
    {
	char *bytes;
	int length, found, i;

	found = 0;
	for (i=0 ; i<localTablePtr->numBuckets ; i++) {
	    for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
		    localPtr=localPtr->nextPtr) {
		if (localPtr->objPtr == objPtr) {
		    found = 1;
		}
	    }
	}

	if (!found) {
	    bytes = Tcl_GetStringFromObj(objPtr, &length);
	    Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
		    "AddLocalLiteralEntry", (length>60? 60 : length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * ExpandLocalLiteralArray --
 *
 *	Function that uses malloc to allocate more storage for a CompileEnv's
 *	local literal array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The literal array in *envPtr is reallocated to a new array of double
 *	the size, and if envPtr->mallocedLiteralArray is non-zero the old
 *	array is freed. Entries are copied from the old array to the new one.
 *	The local literal table is updated to refer to the new entries.
 *
 *----------------------------------------------------------------------
 */

static void
ExpandLocalLiteralArray(
    register CompileEnv *envPtr)/* Points to the CompileEnv whose object array
				 * must be enlarged. */
{
    /*
     * The current allocated local literal entries are stored between elements
     * 0 and (envPtr->literalArrayNext - 1) [inclusive].
     */

    LiteralTable *localTablePtr = &envPtr->localLitTable;
    int currElems = envPtr->literalArrayNext;
    size_t currBytes = (currElems * sizeof(LiteralEntry));
    LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
    LiteralEntry *newArrayPtr;
    int i;

    if (envPtr->mallocedLiteralArray) {
	newArrayPtr = ckrealloc(currArrayPtr, 2 * currBytes);
    } else {
	/*
	 * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must
	 * code a ckrealloc equivalent for ourselves.
	 */

	newArrayPtr = ckalloc(2 * currBytes);
	memcpy(newArrayPtr, currArrayPtr, currBytes);
	envPtr->mallocedLiteralArray = 1;
    }

    /*
     * Update the local literal table's bucket array.
     */

    if (currArrayPtr != newArrayPtr) {
	for (i=0 ; i<currElems ; i++) {
	    if (newArrayPtr[i].nextPtr != NULL) {
		newArrayPtr[i].nextPtr = newArrayPtr
			+ (newArrayPtr[i].nextPtr - currArrayPtr);
	    }
	}
	for (i=0 ; i<localTablePtr->numBuckets ; i++) {
	    if (localTablePtr->buckets[i] != NULL) {
		localTablePtr->buckets[i] = newArrayPtr
			+ (localTablePtr->buckets[i] - currArrayPtr);
	    }
	}
    }

    envPtr->literalArrayPtr = newArrayPtr;
    envPtr->literalArrayEnd = (2 * currElems);
}

/*
 *----------------------------------------------------------------------
 *
 * TclReleaseLiteral --
 *
 *	This function releases a reference to one of the shared Tcl objects
 *	that hold literals. It is called to release the literals referenced by
 *	a ByteCode that is being destroyed, and it is also called by
 *	TclDeleteLiteralTable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count for the global LiteralTable entry that corresponds
 *	to the literal is decremented. If no other reference to a global
 *	literal object remains, it is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclReleaseLiteral(
    Tcl_Interp *interp,		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register Tcl_Obj *objPtr)	/* Points to a literal object that was
				 * previously created by a call to
				 * TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
    LiteralTable *globalTablePtr;
    register LiteralEntry *entryPtr, *prevPtr;
    const char *bytes;
    int length, index;

    if (iPtr == NULL) {
	goto done;
    }

    globalTablePtr = &iPtr->literalTable;
    bytes = TclGetStringFromObj(objPtr, &length);
    index = (HashString(bytes, length) & globalTablePtr->mask);

    /*
     * Check to see if the object is in the global literal table and remove
     * this reference. The object may not be in the table if it is a hidden
     * local literal.
     */

    for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index];
	    entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) {
	if (entryPtr->objPtr == objPtr) {
	    entryPtr->refCount--;

	    /*
	     * If the literal is no longer being used by any ByteCode, delete
	     * the entry then remove the reference corresponding to the global
	     * literal table entry (decrement the ref count of the object).
	     */

	    if (entryPtr->refCount == 0) {
		if (prevPtr == NULL) {
		    globalTablePtr->buckets[index] = entryPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = entryPtr->nextPtr;
		}
		ckfree(entryPtr);
		globalTablePtr->numEntries--;

		TclDecrRefCount(objPtr);

#ifdef TCL_COMPILE_STATS
		iPtr->stats.currentLitStringBytes -= (double) (length + 1);
#endif /*TCL_COMPILE_STATS*/
	    }
	    break;
	}
    }

    /*
     * Remove the reference corresponding to the local literal table entry.
     */

    done:
    Tcl_DecrRefCount(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * HashString --
 *
 *	Compute a one-word summary of a text string, which can be used to
 *	generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned
HashString(
    register const char *string,	/* String for which to compute hash value. */
    int length)			/* Number of bytes in the string. */
{
    register unsigned int result = 0;

    /*
     * I tried a zillion different hash functions and asked many other people
     * for advice. Many people had their own favorite functions, all
     * different, but no-one had much idea why they were good ones. I chose
     * the one below (multiply by 9 and add new character) because of the
     * following reasons:
     *
     * 1. Multiplying by 10 is perfect for keys that are decimal strings, and
     *    multiplying by 9 is just about as good.
     * 2. Times-9 is (shift-left-3) plus (old). This means that each
     *    character's bits hang around in the low-order bits of the hash value
     *    for ever, plus they spread fairly rapidly up to the high-order bits
     *    to fill out the hash value. This seems works well both for decimal
     *    and non-decimal strings.
     *
     * Note that this function is very weak against malicious strings; it's
     * very easy to generate multiple keys that have the same hashcode. On the
     * other hand, that hardly ever actually occurs and this function *is*
     * very cheap, even by comparison with industry-standard hashes like FNV.
     * If real strength of hash is required though, use a custom hash based on
     * Bob Jenkins's lookup3(), but be aware that it's significantly slower.
     * Tcl scripts tend to not have a big issue in this area, and literals
     * mostly aren't looked up by name anyway.
     *
     * See also HashStringKey in tclHash.c.
     * See also TclObjHashKey in tclObj.c.
     *
     * See [tcl-Feature Request #2958832]
     */

    if (length > 0) {
	result = UCHAR(*string);
	while (--length) {
	    result += (result << 3) + UCHAR(*++string);
	}
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * RebuildLiteralTable --
 *
 *	This function is invoked when the ratio of entries to hash buckets
 *	becomes too large in a local or global literal table. It allocates a
 *	larger bucket array and moves the entries into the new buckets.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets reallocated and entries get rehashed into new buckets.
 *
 *----------------------------------------------------------------------
 */

static void
RebuildLiteralTable(
    register LiteralTable *tablePtr)
				/* Local or global table to enlarge. */
{
    LiteralEntry **oldBuckets;
    register LiteralEntry **oldChainPtr, **newChainPtr;
    register LiteralEntry *entryPtr;
    LiteralEntry **bucketPtr;
    const char *bytes;
    int oldSize, count, index, length;

    oldSize = tablePtr->numBuckets;
    oldBuckets = tablePtr->buckets;

    /*
     * Allocate and initialize the new bucket array, and set up hashing
     * constants for new array size.
     */

    tablePtr->numBuckets *= 4;
    tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*));
    for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
	    count>0 ; count--, newChainPtr++) {
	*newChainPtr = NULL;
    }
    tablePtr->rebuildSize *= 4;
    tablePtr->mask = (tablePtr->mask << 2) + 3;

    /*
     * Rehash all of the existing entries into the new bucket array.
     */

    for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
	for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
	    bytes = TclGetStringFromObj(entryPtr->objPtr, &length);
	    index = (HashString(bytes, length) & tablePtr->mask);

	    *oldChainPtr = entryPtr->nextPtr;
	    bucketPtr = &tablePtr->buckets[index];
	    entryPtr->nextPtr = *bucketPtr;
	    *bucketPtr = entryPtr;
	}
    }

    /*
     * Free up the old bucket array, if it was dynamically allocated.
     */

    if (oldBuckets != tablePtr->staticBuckets) {
	ckfree(oldBuckets);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclInvalidateCmdLiteral --
 *
 *	Invalidate a command literal entry, if present in the literal hash
 *	tables, by resetting its internal representation. This invalidation
 *	leaves it in the literal tables and in existing literal arrays. As a
 *	result, existing references continue to work but we force a fresh
 *	command look-up upon the next use (see, in particular,
 *	TclSetCmdNameObj()).
 *
 * Results:
 *	None.
 *
 * Side effects: 
 *	Resets the internal representation of the CmdName Tcl_Obj
 *	using TclFreeIntRep().
 *
 *----------------------------------------------------------------------
 */

void
TclInvalidateCmdLiteral(
    Tcl_Interp *interp,		/* Interpreter for which to invalidate a
				 * command literal. */
    const char *name,		/* Points to the start of the cmd literal
				 * name. */
    Namespace *nsPtr)		/* The namespace for which to lookup and
				 * invalidate a cmd literal. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
	    strlen(name), -1, NULL, nsPtr, 0, NULL);

    if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) {
	TclFreeIntRep(literalObjPtr);
    }
}

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * TclLiteralStats --
 *
 *	Return statistics describing the layout of the hash table in its hash
 *	buckets.
 *
 * Results:
 *	The return value is a malloc-ed string containing information about
 *	tablePtr. It is the caller's responsibility to free this string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclLiteralStats(
    LiteralTable *tablePtr)	/* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
    int count[NUM_COUNTERS], overflow, i, j;
    double average, tmp;
    register LiteralEntry *entryPtr;
    char *result, *p;

    /*
     * Compute a histogram of bucket usage. For each bucket chain i, j is the
     * number of entries in the chain.
     */

    for (i=0 ; i<NUM_COUNTERS ; i++) {
	count[i] = 0;
    }
    overflow = 0;
    average = 0.0;
    for (i=0 ; i<tablePtr->numBuckets ; i++) {
	j = 0;
	for (entryPtr=tablePtr->buckets[i] ; entryPtr!=NULL;
		entryPtr=entryPtr->nextPtr) {
	    j++;
	}
	if (j < NUM_COUNTERS) {
	    count[j]++;
	} else {
	    overflow++;
	}
	tmp = j;
	average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
    }

    /*
     * Print out the histogram and a few other pieces of information.
     */

    result = ckalloc(NUM_COUNTERS*60 + 300);
    sprintf(result, "%d entries in table, %d buckets\n",
	    tablePtr->numEntries, tablePtr->numBuckets);
    p = result + strlen(result);
    for (i=0 ; i<NUM_COUNTERS ; i++) {
	sprintf(p, "number of buckets with %d entries: %d\n",
		i, count[i]);
	p += strlen(p);
    }
    sprintf(p, "number of buckets with %d or more entries: %d\n",
	    NUM_COUNTERS, overflow);
    p += strlen(p);
    sprintf(p, "average search distance for entry: %.1f", average);
    return result;
}
#endif /*TCL_COMPILE_STATS*/

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * TclVerifyLocalLiteralTable --
 *
 *	Check a CompileEnv's local literal table for consistency.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Tcl_Panic if problems are found.
 *
 *----------------------------------------------------------------------
 */

void
TclVerifyLocalLiteralTable(
    CompileEnv *envPtr)		/* Points to CompileEnv whose literal table is
				 * to be validated. */
{
    register LiteralTable *localTablePtr = &envPtr->localLitTable;
    register LiteralEntry *localPtr;
    char *bytes;
    register int i;
    int length, count;

    count = 0;
    for (i=0 ; i<localTablePtr->numBuckets ; i++) {
	for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
		localPtr=localPtr->nextPtr) {
	    count++;
	    if (localPtr->refCount != -1) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d",
			"TclVerifyLocalLiteralTable",
			(length>60? 60 : length), bytes, localPtr->refCount);
	    }
	    if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
		    localPtr->objPtr) == NULL) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("%s: local literal \"%.*s\" is not global",
			"TclVerifyLocalLiteralTable",
			(length>60? 60 : length), bytes);
	    }
	    if (localPtr->objPtr->bytes == NULL) {
		Tcl_Panic("%s: literal has NULL string rep",
			"TclVerifyLocalLiteralTable");
	    }
	}
    }
    if (count != localTablePtr->numEntries) {
	Tcl_Panic("%s: local literal table had %d entries, should be %d",
		"TclVerifyLocalLiteralTable", count,
		localTablePtr->numEntries);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclVerifyGlobalLiteralTable --
 *
 *	Check an interpreter's global literal table literal for consistency.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Tcl_Panic if problems are found.
 *
 *----------------------------------------------------------------------
 */

void
TclVerifyGlobalLiteralTable(
    Interp *iPtr)		/* Points to interpreter whose global literal
				 * table is to be validated. */
{
    register LiteralTable *globalTablePtr = &iPtr->literalTable;
    register LiteralEntry *globalPtr;
    char *bytes;
    register int i;
    int length, count;

    count = 0;
    for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
	for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
		globalPtr=globalPtr->nextPtr) {
	    count++;
	    if (globalPtr->refCount < 1) {
		bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
		Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
			"TclVerifyGlobalLiteralTable",
			(length>60? 60 : length), bytes, globalPtr->refCount);
	    }
	    if (globalPtr->objPtr->bytes == NULL) {
		Tcl_Panic("%s: literal has NULL string rep",
			"TclVerifyGlobalLiteralTable");
	    }
	}
    }
    if (count != globalTablePtr->numEntries) {
	Tcl_Panic("%s: global literal table had %d entries, should be %d",
		"TclVerifyGlobalLiteralTable", count,
		globalTablePtr->numEntries);
    }
}
#endif /*TCL_COMPILE_DEBUG*/

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */