From f080563e1ce42aff0aa7cdcfc64a5d6da7286abc Mon Sep 17 00:00:00 2001 From: surles Date: Wed, 5 May 1999 00:35:41 +0000 Subject: fixed memory leak --- generic/tclLiteral.c | 2110 +++++++++++++++++++++++++------------------------- 1 file changed, 1062 insertions(+), 1048 deletions(-) diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index f180d11..99e46ae 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -1,1048 +1,1062 @@ -/* - * 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. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLiteral.c,v 1.4 1999/04/28 01:56:39 stanton Exp $ - */ - -#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 - -/* - * Procedure prototypes for static procedures in this file: - */ - -static int AddLocalLiteralEntry _ANSI_ARGS_(( - CompileEnv *envPtr, LiteralEntry *globalPtr, - int localHash)); -static void ExpandLocalLiteralArray _ANSI_ARGS_(( - CompileEnv *envPtr)); -static unsigned int HashString _ANSI_ARGS_((CONST char *bytes, - int length)); -static void RebuildLiteralTable _ANSI_ARGS_(( - LiteralTable *tablePtr)); - -/* - *---------------------------------------------------------------------- - * - * TclInitLiteralTable -- - * - * This procedure 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(tablePtr) - register LiteralTable *tablePtr; /* Pointer to table structure, which - * is supplied by the caller. */ -{ -#if (TCL_SMALL_HASH_TABLE != 4) - panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", - 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 procedure frees up everything associated with a literal table - * except for the table's structure itself. - * - * 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(interp, tablePtr) - Tcl_Interp *interp; /* Interpreter containing shared literals - * referenced by the table to delete. */ - LiteralTable *tablePtr; /* Points to the literal table to delete. */ -{ - LiteralEntry *entryPtr; - int i, start; - - /* - * 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*/ - - start = 0; - while (tablePtr->numEntries > 0) { - for (i = start; i < tablePtr->numBuckets; i++) { - entryPtr = tablePtr->buckets[i]; - if (entryPtr != NULL) { - TclReleaseLiteral(interp, entryPtr->objPtr); - start = i; - break; - } - } - } - - /* - * Free up the table's bucket array if it was dynamically allocated. - */ - - if (tablePtr->buckets != tablePtr->staticBuckets) { - ckfree((char *) tablePtr->buckets); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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 onHeap is 1, this procedure 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 - * onHeap 1 if "string" is an already heap-allocated buffer holding the - * result of backslash substitutions. - * - *---------------------------------------------------------------------- - */ - -int -TclRegisterLiteral(envPtr, bytes, length, onHeap) - 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 onHeap; /* If 1 then the caller already malloc'd - * bytes and ownership is passed to this - * procedure. */ -{ - Interp *iPtr = envPtr->iPtr; - LiteralTable *globalTablePtr = &(iPtr->literalTable); - LiteralTable *localTablePtr = &(envPtr->localLitTable); - register LiteralEntry *globalPtr, *localPtr; - register Tcl_Obj *objPtr; - unsigned int hash; - int localHash, globalHash, objIndex; - long n; - char buf[TCL_INTEGER_SPACE]; - - 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 (onHeap) { - 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. Is it in the interpreter's - * global literal table? - */ - - globalHash = (hash & globalTablePtr->mask); - for (globalPtr = globalTablePtr->buckets[globalHash]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { - objPtr = globalPtr->objPtr; - if ((objPtr->length == length) && ((length == 0) - || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) - == 0)))) { - /* - * A global literal was found. Add an entry to the CompileEnv's - * local literal array. - */ - - if (onHeap) { - ckfree(bytes); - } - objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); -#ifdef TCL_COMPILE_DEBUG - if (globalPtr->refCount < 1) { - panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - globalPtr->refCount); - } - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ - return objIndex; - } - } - - /* - * The literal is new to the interpreter. Add it to the global literal - * table then add an entry to the CompileEnv's local literal array. - * Convert the object to an integer object if possible. - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - if (onHeap) { - objPtr->bytes = bytes; - objPtr->length = length; - } else { - TclInitStringRep(objPtr, bytes, length); - } - if (TclLooksLikeInt(bytes, length)) { - if (TclGetLong((Tcl_Interp *) NULL, bytes, &n) == TCL_OK) { - TclFormatInt(buf, n); - if (strcmp(bytes, buf) == 0) { - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - } - } - } - -#ifdef TCL_COMPILE_DEBUG - if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { - panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", - (length>60? 60 : length), bytes); - } -#endif - - globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); - globalPtr->objPtr = objPtr; - globalPtr->refCount = 0; - 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); - } - - objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); - -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); - TclVerifyLocalLiteralTable(envPtr); - { - 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) { - panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", - (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*/ - return objIndex; -} - -/* - *---------------------------------------------------------------------- - * - * TclLookupLiteralEntry -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -LiteralEntry * -TclLookupLiteralEntry(interp, objPtr) - 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; - char *bytes; - int length, globalHash; - - bytes = Tcl_GetStringFromObj(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; -} - -/* - *---------------------------------------------------------------------- - * - * 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(interp, envPtr, index) - 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; - 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 = Tcl_GetStringFromObj(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(envPtr, objPtr, litPtrPtr) - 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: - * Increments the ref count of the global LiteralEntry since the - * CompileEnv now refers to the literal. 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(envPtr, globalPtr, localHash) - register CompileEnv *envPtr; /* Points to CompileEnv in whose literal - * array the object is to be inserted. */ - LiteralEntry *globalPtr; /* Points to the global LiteralEntry for - * 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, globalPtr->objPtr, &localPtr); - - /* - * Add the literal to the local table. - */ - - localPtr->nextPtr = localTablePtr->buckets[localHash]; - localTablePtr->buckets[localHash] = localPtr; - localTablePtr->numEntries++; - - globalPtr->refCount++; - - /* - * 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 == globalPtr->objPtr) { - found = 1; - } - } - } - if (!found) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); - panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", - (length>60? 60 : length), bytes); - } - } -#endif /*TCL_COMPILE_DEBUG*/ - return objIndex; -} - -/* - *---------------------------------------------------------------------- - * - * ExpandLocalLiteralArray -- - * - * Procedure 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(envPtr) - 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)); - register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; - register LiteralEntry *newArrayPtr = - (LiteralEntry *) ckalloc((unsigned) (2 * currBytes)); - int i; - - /* - * Copy from the old literal array to the new, then update the local - * literal table's bucket array. - */ - - memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes); - for (i = 0; i < currElems; i++) { - if (currArrayPtr[i].nextPtr == NULL) { - newArrayPtr[i].nextPtr = NULL; - } else { - newArrayPtr[i].nextPtr = newArrayPtr - + (currArrayPtr[i].nextPtr - currArrayPtr); - } - } - for (i = 0; i < localTablePtr->numBuckets; i++) { - if (localTablePtr->buckets[i] != NULL) { - localTablePtr->buckets[i] = newArrayPtr - + (localTablePtr->buckets[i] - currArrayPtr); - } - } - - /* - * Free the old literal array if needed, and mark the new literal - * array as malloced. - */ - - if (envPtr->mallocedLiteralArray) { - ckfree((char *) currArrayPtr); - } - envPtr->literalArrayPtr = newArrayPtr; - envPtr->literalArrayEnd = (2 * currElems); - envPtr->mallocedLiteralArray = 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclReleaseLiteral -- - * - * This procedure 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(interp, objPtr) - 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 = &(iPtr->literalTable); - register LiteralEntry *entryPtr, *prevPtr; - ByteCode* codePtr; - char *bytes; - int length, index; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - index = (HashString(bytes, length) & globalTablePtr->mask); - for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index]; - entryPtr != NULL; - prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr == objPtr) { - entryPtr->refCount--; - - /* - * We found the matching LiteralEntry. Check if it's only being - * kept alive only by a circular reference from a ByteCode - * stored as its internal rep. - */ - - if ((entryPtr->refCount == 1) - && (objPtr->typePtr == &tclByteCodeType)) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->numLitObjects == 1) - && (codePtr->objArrayPtr[0] == objPtr)) { - entryPtr->refCount = 0; - - /* - * Set the ByteCode object array entry NULL to signal - * to TclCleanupByteCode to not try to release this - * about to be freed literal again. - */ - - codePtr->objArrayPtr[0] = NULL; - } - } - - /* - * If the literal is no longer being used by any ByteCode, - * delete the entry then decrement the ref count of its object. - */ - - if (entryPtr->refCount == 0) { - if (prevPtr == NULL) { - globalTablePtr->buckets[index] = entryPtr->nextPtr; - } else { - prevPtr->nextPtr = entryPtr->nextPtr; - } -#ifdef TCL_COMPILE_STATS - iPtr->stats.currentLitStringBytes -= (double) (length + 1); -#endif /*TCL_COMPILE_STATS*/ - ckfree((char *) entryPtr); - globalTablePtr->numEntries--; - TclDecrRefCount(objPtr); - } - return; - } - } - - /* - * The object wasn't in the literal hash table, so it must be a unique - * local object in the object table that has no global entry. Just - * decrement the refcount and return. - */ - - 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 int -HashString(bytes, length) - register CONST char *bytes; /* String for which to compute hash - * value. */ - int length; /* Number of bytes in the string. */ -{ - register unsigned int result; - register int i; - - /* - * 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. - */ - - result = 0; - for (i = 0; i < length; i++) { - result += (result<<3) + *bytes++; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * RebuildLiteralTable -- - * - * This procedure 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(tablePtr) - register LiteralTable *tablePtr; /* Local or global table to enlarge. */ -{ - LiteralEntry **oldBuckets; - register LiteralEntry **oldChainPtr, **newChainPtr; - register LiteralEntry *entryPtr; - LiteralEntry **bucketPtr; - 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 = (LiteralEntry **) ckalloc((unsigned) - (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 = Tcl_GetStringFromObj(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((char *) oldBuckets); - } -} - -#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(tablePtr) - 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 = (char *) ckalloc((unsigned) ((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: - * Panics if problems are found. - * - *---------------------------------------------------------------------- - */ - -void -TclVerifyLocalLiteralTable(envPtr) - 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); - panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - localPtr->refCount); - } - if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, - localPtr->objPtr) == NULL) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", - (length>60? 60 : length), bytes); - } - if (localPtr->objPtr->bytes == NULL) { - panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); - } - } - } - if (count != localTablePtr->numEntries) { - panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", - count, localTablePtr->numEntries); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclVerifyGlobalLiteralTable -- - * - * Check an interpreter's global literal table literal for consistency. - * - * Results: - * None. - * - * Side effects: - * Panics if problems are found. - * - *---------------------------------------------------------------------- - */ - -void -TclVerifyGlobalLiteralTable(iPtr) - 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); - panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - globalPtr->refCount); - } - if (globalPtr->objPtr->bytes == NULL) { - panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); - } - } - } - if (count != globalTablePtr->numEntries) { - panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", - count, globalTablePtr->numEntries); - } -} -#endif /*TCL_COMPILE_DEBUG*/ +/* + * 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclLiteral.c,v 1.5 1999/05/05 00:35:41 surles Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include "tclPort.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 + +/* + * Procedure prototypes for static procedures in this file: + */ + +static int AddLocalLiteralEntry _ANSI_ARGS_(( + CompileEnv *envPtr, LiteralEntry *globalPtr, + int localHash)); +static void ExpandLocalLiteralArray _ANSI_ARGS_(( + CompileEnv *envPtr)); +static unsigned int HashString _ANSI_ARGS_((CONST char *bytes, + int length)); +static void RebuildLiteralTable _ANSI_ARGS_(( + LiteralTable *tablePtr)); + +/* + *---------------------------------------------------------------------- + * + * TclInitLiteralTable -- + * + * This procedure 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(tablePtr) + register LiteralTable *tablePtr; /* Pointer to table structure, which + * is supplied by the caller. */ +{ +#if (TCL_SMALL_HASH_TABLE != 4) + panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", + 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 procedure frees up everything associated with a literal table + * except for the table's structure itself. + * + * 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(interp, tablePtr) + Tcl_Interp *interp; /* Interpreter containing shared literals + * referenced by the table to delete. */ + LiteralTable *tablePtr; /* Points to the literal table to delete. */ +{ + LiteralEntry *entryPtr; + int i, start; + + /* + * 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*/ + + start = 0; + while (tablePtr->numEntries > 0) { + for (i = start; i < tablePtr->numBuckets; i++) { + entryPtr = tablePtr->buckets[i]; + if (entryPtr != NULL) { + TclReleaseLiteral(interp, entryPtr->objPtr); + start = i; + break; + } + } + } + + /* + * Free up the table's bucket array if it was dynamically allocated. + */ + + if (tablePtr->buckets != tablePtr->staticBuckets) { + ckfree((char *) tablePtr->buckets); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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 onHeap is 1, this procedure 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 + * onHeap 1 if "string" is an already heap-allocated buffer holding the + * result of backslash substitutions. + * + *---------------------------------------------------------------------- + */ + +int +TclRegisterLiteral(envPtr, bytes, length, onHeap) + 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 onHeap; /* If 1 then the caller already malloc'd + * bytes and ownership is passed to this + * procedure. */ +{ + Interp *iPtr = envPtr->iPtr; + LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralEntry *globalPtr, *localPtr; + register Tcl_Obj *objPtr; + unsigned int hash; + int localHash, globalHash, objIndex; + long n; + char buf[TCL_INTEGER_SPACE]; + + + 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 (onHeap) { + 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. Is it in the interpreter's + * global literal table? + */ + + globalHash = (hash & globalTablePtr->mask); + for (globalPtr = globalTablePtr->buckets[globalHash]; + globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + objPtr = globalPtr->objPtr; + if ((objPtr->length == length) && ((length == 0) + || ((objPtr->bytes[0] == bytes[0]) + && (memcmp(objPtr->bytes, bytes, (unsigned) length) + == 0)))) { + /* + * A global literal was found. Add an entry to the CompileEnv's + * local literal array. + */ + + if (onHeap) { + ckfree(bytes); + } + objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); +#ifdef TCL_COMPILE_DEBUG + if (globalPtr->refCount < 1) { + panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, + globalPtr->refCount); + } + TclVerifyLocalLiteralTable(envPtr); +#endif /*TCL_COMPILE_DEBUG*/ + return objIndex; + } + } + + /* + * The literal is new to the interpreter. Add it to the global literal + * table then add an entry to the CompileEnv's local literal array. + * Convert the object to an integer object if possible. + */ + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + if (onHeap) { + objPtr->bytes = bytes; + objPtr->length = length; + } else { + TclInitStringRep(objPtr, bytes, length); + } + + if (TclLooksLikeInt(bytes, length)) { + if (TclGetLong((Tcl_Interp *) NULL, bytes, &n) == TCL_OK) { + TclFormatInt(buf, n); + if (strcmp(bytes, buf) == 0) { + objPtr->internalRep.longValue = n; + objPtr->typePtr = &tclIntType; + } + } + } + +#ifdef TCL_COMPILE_DEBUG + if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { + panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", + (length>60? 60 : length), bytes); + } +#endif + + globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); + globalPtr->objPtr = objPtr; + globalPtr->refCount = 0; + 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); + } + + objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); + +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); + TclVerifyLocalLiteralTable(envPtr); + { + 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) { + panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", + (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*/ + return objIndex; +} + +/* + *---------------------------------------------------------------------- + * + * TclLookupLiteralEntry -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +LiteralEntry * +TclLookupLiteralEntry(interp, objPtr) + 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; + char *bytes; + int length, globalHash; + + bytes = Tcl_GetStringFromObj(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; +} + +/* + *---------------------------------------------------------------------- + * + * 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(interp, envPtr, index) + 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; + 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 = Tcl_GetStringFromObj(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(envPtr, objPtr, litPtrPtr) + 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: + * Increments the ref count of the global LiteralEntry since the + * CompileEnv now refers to the literal. 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(envPtr, globalPtr, localHash) + register CompileEnv *envPtr; /* Points to CompileEnv in whose literal + * array the object is to be inserted. */ + LiteralEntry *globalPtr; /* Points to the global LiteralEntry for + * 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, globalPtr->objPtr, &localPtr); + + /* + * Add the literal to the local table. + */ + + localPtr->nextPtr = localTablePtr->buckets[localHash]; + localTablePtr->buckets[localHash] = localPtr; + localTablePtr->numEntries++; + + globalPtr->refCount++; + + /* + * 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 == globalPtr->objPtr) { + found = 1; + } + } + } + if (!found) { + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", + (length>60? 60 : length), bytes); + } + } +#endif /*TCL_COMPILE_DEBUG*/ + return objIndex; +} + +/* + *---------------------------------------------------------------------- + * + * ExpandLocalLiteralArray -- + * + * Procedure 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(envPtr) + 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)); + register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; + register LiteralEntry *newArrayPtr = + (LiteralEntry *) ckalloc((unsigned) (2 * currBytes)); + int i; + + /* + * Copy from the old literal array to the new, then update the local + * literal table's bucket array. + */ + + memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes); + for (i = 0; i < currElems; i++) { + if (currArrayPtr[i].nextPtr == NULL) { + newArrayPtr[i].nextPtr = NULL; + } else { + newArrayPtr[i].nextPtr = newArrayPtr + + (currArrayPtr[i].nextPtr - currArrayPtr); + } + } + for (i = 0; i < localTablePtr->numBuckets; i++) { + if (localTablePtr->buckets[i] != NULL) { + localTablePtr->buckets[i] = newArrayPtr + + (localTablePtr->buckets[i] - currArrayPtr); + } + } + + /* + * Free the old literal array if needed, and mark the new literal + * array as malloced. + */ + + if (envPtr->mallocedLiteralArray) { + ckfree((char *) currArrayPtr); + } + envPtr->literalArrayPtr = newArrayPtr; + envPtr->literalArrayEnd = (2 * currElems); + envPtr->mallocedLiteralArray = 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclReleaseLiteral -- + * + * This procedure 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(interp, objPtr) + 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 = &(iPtr->literalTable); + register LiteralEntry *entryPtr, *prevPtr; + ByteCode* codePtr; + char *bytes; + int length, index; + + bytes = Tcl_GetStringFromObj(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--; + + /* + * We found the matching LiteralEntry. Check if it's only being + * kept alive only by a circular reference from a ByteCode + * stored as its internal rep. + */ + + if ((entryPtr->refCount == 1) + && (objPtr->typePtr == &tclByteCodeType)) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if ((codePtr->numLitObjects == 1) + && (codePtr->objArrayPtr[0] == objPtr)) { + entryPtr->refCount = 0; + + /* + * Set the ByteCode object array entry NULL to signal + * to TclCleanupByteCode to not try to release this + * about to be freed literal again. + */ + + codePtr->objArrayPtr[0] = NULL; + } + } + + /* + * If the literal is no longer being used by any ByteCode, + * delete the entry then decrement the ref count of its object. + */ + + if (entryPtr->refCount == 0) { + if (prevPtr == NULL) { + globalTablePtr->buckets[index] = entryPtr->nextPtr; + } else { + prevPtr->nextPtr = entryPtr->nextPtr; + } +#ifdef TCL_COMPILE_STATS + iPtr->stats.currentLitStringBytes -= (double) (length + 1); +#endif /*TCL_COMPILE_STATS*/ + ckfree((char *) entryPtr); + globalTablePtr->numEntries--; + + /* + * Remove the reference corresponding to the global + * literal table entry. + */ + + TclDecrRefCount(objPtr); + } + break; + } + } + + /* + * Remove the reference corresponding to the local literal table + * entry. + */ + + 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 int +HashString(bytes, length) + register CONST char *bytes; /* String for which to compute hash + * value. */ + int length; /* Number of bytes in the string. */ +{ + register unsigned int result; + register int i; + + /* + * 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. + */ + + result = 0; + for (i = 0; i < length; i++) { + result += (result<<3) + *bytes++; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * RebuildLiteralTable -- + * + * This procedure 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(tablePtr) + register LiteralTable *tablePtr; /* Local or global table to enlarge. */ +{ + LiteralEntry **oldBuckets; + register LiteralEntry **oldChainPtr, **newChainPtr; + register LiteralEntry *entryPtr; + LiteralEntry **bucketPtr; + 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 = (LiteralEntry **) ckalloc((unsigned) + (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 = Tcl_GetStringFromObj(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((char *) oldBuckets); + } +} + +#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(tablePtr) + 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 = (char *) ckalloc((unsigned) ((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: + * Panics if problems are found. + * + *---------------------------------------------------------------------- + */ + +void +TclVerifyLocalLiteralTable(envPtr) + 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); + panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, + localPtr->refCount); + } + if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, + localPtr->objPtr) == NULL) { + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", + (length>60? 60 : length), bytes); + } + if (localPtr->objPtr->bytes == NULL) { + panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); + } + } + } + if (count != localTablePtr->numEntries) { + panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", + count, localTablePtr->numEntries); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclVerifyGlobalLiteralTable -- + * + * Check an interpreter's global literal table literal for consistency. + * + * Results: + * None. + * + * Side effects: + * Panics if problems are found. + * + *---------------------------------------------------------------------- + */ + +void +TclVerifyGlobalLiteralTable(iPtr) + 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); + panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, + globalPtr->refCount); + } + if (globalPtr->objPtr->bytes == NULL) { + panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); + } + } + } + if (count != globalTablePtr->numEntries) { + panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", + count, globalTablePtr->numEntries); + } +} +#endif /*TCL_COMPILE_DEBUG*/ -- cgit v0.12