summaryrefslogtreecommitdiffstats
path: root/generic/tclLiteral.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclLiteral.c')
-rw-r--r--generic/tclLiteral.c2110
1 files 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*/
generated by cgit v0.12 at 2024-11-18 20:59:01 (GMT)