shared_source/c_tcl_base_7_5_w_mods/tclliteral.c

/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclliteral.c,v 1.1.1.1 2001/06/13 04:42:47 dtashley Exp $ */

/* 
 * 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.1.1.1 2001/06/13 04:42:47 dtashley 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)) {
        /*
         * From here we use the objPtr, because it is NULL terminated
         */
        if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
            TclFormatInt(buf, n);
            if (strcmp(objPtr->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*/


/* $History: tclliteral.c $
 * 
 * *****************  Version 1  *****************
 * User: Dtashley     Date: 1/02/01    Time: 1:32a
 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
 * Initial check-in.
 */ 

/* End of TCLLITERAL.C */