sl@0: /* 
sl@0:  * tclLiteral.c --
sl@0:  *
sl@0:  *	Implementation of the global and ByteCode-local literal tables
sl@0:  *	used to manage the Tcl objects created for literal values during
sl@0:  *	compilation of Tcl scripts. This implementation borrows heavily
sl@0:  *	from the more general hashtable implementation of Tcl hash tables
sl@0:  *	that appears in tclHash.c.
sl@0:  *
sl@0:  * Copyright (c) 1997-1998 Sun Microsystems, Inc.
sl@0:  *
sl@0:  * See the file "license.terms" for information on usage and redistribution
sl@0:  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0:  *
sl@0:  * RCS: @(#) $Id: tclLiteral.c,v 1.11 2001/10/11 22:28:01 msofer Exp $
sl@0:  */
sl@0: 
sl@0: #include "tclInt.h"
sl@0: #include "tclCompile.h"
sl@0: #include "tclPort.h"
sl@0: /*
sl@0:  * When there are this many entries per bucket, on average, rebuild
sl@0:  * a literal's hash table to make it larger.
sl@0:  */
sl@0: 
sl@0: #define REBUILD_MULTIPLIER	3
sl@0: 
sl@0: /*
sl@0:  * Procedure prototypes for static procedures in this file:
sl@0:  */
sl@0: 
sl@0: static int		AddLocalLiteralEntry _ANSI_ARGS_((
sl@0: 			    CompileEnv *envPtr, LiteralEntry *globalPtr,
sl@0: 			    int localHash));
sl@0: static void		ExpandLocalLiteralArray _ANSI_ARGS_((
sl@0: 			    CompileEnv *envPtr));
sl@0: static unsigned int	HashString _ANSI_ARGS_((CONST char *bytes,
sl@0: 			    int length));
sl@0: static void		RebuildLiteralTable _ANSI_ARGS_((
sl@0: 			    LiteralTable *tablePtr));
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclInitLiteralTable --
sl@0:  *
sl@0:  *	This procedure is called to initialize the fields of a literal table
sl@0:  *	structure for either an interpreter or a compilation's CompileEnv
sl@0:  *	structure.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects: 
sl@0:  *	The literal table is made ready for use.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclInitLiteralTable(tablePtr)
sl@0:     register LiteralTable *tablePtr; /* Pointer to table structure, which
sl@0: 				      * is supplied by the caller. */
sl@0: {
sl@0: #if (TCL_SMALL_HASH_TABLE != 4) 
sl@0:     panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
sl@0: 	    TCL_SMALL_HASH_TABLE);
sl@0: #endif
sl@0:     
sl@0:     tablePtr->buckets = tablePtr->staticBuckets;
sl@0:     tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
sl@0:     tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
sl@0:     tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
sl@0:     tablePtr->numEntries = 0;
sl@0:     tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
sl@0:     tablePtr->mask = 3;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclDeleteLiteralTable --
sl@0:  *
sl@0:  *	This procedure frees up everything associated with a literal table
sl@0:  *	except for the table's structure itself.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Each literal in the table is released: i.e., its reference count
sl@0:  *	in the global literal table is decremented and, if it becomes zero,
sl@0:  *	the literal is freed. In addition, the table's bucket array is
sl@0:  *	freed.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclDeleteLiteralTable(interp, tablePtr)
sl@0:     Tcl_Interp *interp;		/* Interpreter containing shared literals
sl@0: 				 * referenced by the table to delete. */
sl@0:     LiteralTable *tablePtr;	/* Points to the literal table to delete. */
sl@0: {
sl@0:     LiteralEntry *entryPtr;
sl@0:     int i, start;
sl@0: 
sl@0:     /*
sl@0:      * Release remaining literals in the table. Note that releasing a
sl@0:      * literal might release other literals, modifying the table, so we
sl@0:      * restart the search from the bucket chain we last found an entry.
sl@0:      */
sl@0: 
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0:     TclVerifyGlobalLiteralTable((Interp *) interp);
sl@0: #endif /*TCL_COMPILE_DEBUG*/
sl@0: 
sl@0:     start = 0;
sl@0:     while (tablePtr->numEntries > 0) {
sl@0: 	for (i = start;  i < tablePtr->numBuckets;  i++) {
sl@0: 	    entryPtr = tablePtr->buckets[i];
sl@0: 	    if (entryPtr != NULL) {
sl@0: 		TclReleaseLiteral(interp, entryPtr->objPtr);
sl@0: 		start = i;
sl@0: 		break;
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Free up the table's bucket array if it was dynamically allocated.
sl@0:      */
sl@0: 
sl@0:     if (tablePtr->buckets != tablePtr->staticBuckets) {
sl@0: 	ckfree((char *) tablePtr->buckets);
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclRegisterLiteral --
sl@0:  *
sl@0:  *	Find, or if necessary create, an object in a CompileEnv literal
sl@0:  *	array that has a string representation matching the argument string.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The index in the CompileEnv's literal array that references a
sl@0:  *	shared literal matching the string. The object is created if
sl@0:  *	necessary.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	To maximize sharing, we look up the string in the interpreter's
sl@0:  *	global literal table. If not found, we create a new shared literal
sl@0:  *	in the global table. We then add a reference to the shared
sl@0:  *	literal in the CompileEnv's literal array. 
sl@0:  *
sl@0:  *	If onHeap is 1, this procedure is given ownership of the string: if
sl@0:  *	an object is created then its string representation is set directly
sl@0:  *	from string, otherwise the string is freed. Typically, a caller sets
sl@0:  *	onHeap 1 if "string" is an already heap-allocated buffer holding the
sl@0:  *	result of backslash substitutions.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclRegisterLiteral(envPtr, bytes, length, onHeap)
sl@0:     CompileEnv *envPtr;		/* Points to the CompileEnv in whose object
sl@0: 				 * array an object is found or created. */
sl@0:     register char *bytes;	/* Points to string for which to find or
sl@0: 				 * create an object in CompileEnv's object
sl@0: 				 * array. */
sl@0:     int length;			/* Number of bytes in the string. If < 0,
sl@0: 				 * the string consists of all bytes up to
sl@0: 				 * the first null character. */
sl@0:     int onHeap;			/* If 1 then the caller already malloc'd
sl@0: 				 * bytes and ownership is passed to this
sl@0: 				 * procedure. */
sl@0: {
sl@0:     Interp *iPtr = envPtr->iPtr;
sl@0:     LiteralTable *globalTablePtr = &(iPtr->literalTable);
sl@0:     LiteralTable *localTablePtr = &(envPtr->localLitTable);
sl@0:     register LiteralEntry *globalPtr, *localPtr;
sl@0:     register Tcl_Obj *objPtr;
sl@0:     unsigned int hash;
sl@0:     int localHash, globalHash, objIndex;
sl@0:     long n;
sl@0:     char buf[TCL_INTEGER_SPACE];
sl@0: 
sl@0:     if (length < 0) {
sl@0: 	length = (bytes? strlen(bytes) : 0);
sl@0:     }
sl@0:     hash = HashString(bytes, length);
sl@0: 
sl@0:     /*
sl@0:      * Is the literal already in the CompileEnv's local literal array?
sl@0:      * If so, just return its index.
sl@0:      */
sl@0: 
sl@0:     localHash = (hash & localTablePtr->mask);
sl@0:     for (localPtr = localTablePtr->buckets[localHash];
sl@0: 	  localPtr != NULL;  localPtr = localPtr->nextPtr) {
sl@0: 	objPtr = localPtr->objPtr;
sl@0: 	if ((objPtr->length == length) && ((length == 0)
sl@0: 		|| ((objPtr->bytes[0] == bytes[0])
sl@0: 			&& (memcmp(objPtr->bytes, bytes, (unsigned) length)
sl@0: 				== 0)))) {
sl@0: 	    if (onHeap) {
sl@0: 		ckfree(bytes);
sl@0: 	    }
sl@0: 	    objIndex = (localPtr - envPtr->literalArrayPtr);
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0: 	    TclVerifyLocalLiteralTable(envPtr);
sl@0: #endif /*TCL_COMPILE_DEBUG*/
sl@0: 
sl@0: 	    return objIndex;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * The literal is new to this CompileEnv. Is it in the interpreter's
sl@0:      * global literal table?
sl@0:      */
sl@0: 
sl@0:     globalHash = (hash & globalTablePtr->mask);
sl@0:     for (globalPtr = globalTablePtr->buckets[globalHash];
sl@0: 	 globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
sl@0: 	objPtr = globalPtr->objPtr;
sl@0: 	if ((objPtr->length == length) && ((length == 0)
sl@0: 		|| ((objPtr->bytes[0] == bytes[0])
sl@0: 			&& (memcmp(objPtr->bytes, bytes, (unsigned) length)
sl@0: 				== 0)))) {
sl@0: 	    /*
sl@0: 	     * A global literal was found. Add an entry to the CompileEnv's
sl@0: 	     * local literal array.
sl@0: 	     */
sl@0: 	    
sl@0: 	    if (onHeap) {
sl@0: 		ckfree(bytes);
sl@0: 	    }
sl@0: 	    objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0: 	    if (globalPtr->refCount < 1) {
sl@0: 		panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
sl@0: 			(length>60? 60 : length), bytes,
sl@0: 			globalPtr->refCount);
sl@0: 	    }
sl@0: 	    TclVerifyLocalLiteralTable(envPtr);
sl@0: #endif /*TCL_COMPILE_DEBUG*/ 
sl@0: 	    return objIndex;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * The literal is new to the interpreter. Add it to the global literal
sl@0:      * table then add an entry to the CompileEnv's local literal array.
sl@0:      * Convert the object to an integer object if possible.
sl@0:      */
sl@0: 
sl@0:     TclNewObj(objPtr);
sl@0:     Tcl_IncrRefCount(objPtr);
sl@0:     if (onHeap) {
sl@0: 	objPtr->bytes = bytes;
sl@0: 	objPtr->length = length;
sl@0:     } else {
sl@0: 	TclInitStringRep(objPtr, bytes, length);
sl@0:     }
sl@0: 
sl@0:     if (TclLooksLikeInt(bytes, length)) {
sl@0: 	/*
sl@0: 	 * From here we use the objPtr, because it is NULL terminated
sl@0: 	 */
sl@0: 	if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
sl@0: 	    TclFormatInt(buf, n);
sl@0: 	    if (strcmp(objPtr->bytes, buf) == 0) {
sl@0: 		objPtr->internalRep.longValue = n;
sl@0: 		objPtr->typePtr = &tclIntType;
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0:     if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
sl@0: 	panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
sl@0: 	        (length>60? 60 : length), bytes);
sl@0:     }
sl@0: #endif
sl@0: 
sl@0:     globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
sl@0:     globalPtr->objPtr = objPtr;
sl@0:     globalPtr->refCount = 0;
sl@0:     globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
sl@0:     globalTablePtr->buckets[globalHash] = globalPtr;
sl@0:     globalTablePtr->numEntries++;
sl@0: 
sl@0:     /*
sl@0:      * If the global literal table has exceeded a decent size, rebuild it
sl@0:      * with more buckets.
sl@0:      */
sl@0: 
sl@0:     if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
sl@0: 	RebuildLiteralTable(globalTablePtr);
sl@0:     }
sl@0:     objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
sl@0: 
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0:     TclVerifyGlobalLiteralTable(iPtr);
sl@0:     TclVerifyLocalLiteralTable(envPtr);
sl@0:     {
sl@0: 	LiteralEntry *entryPtr;
sl@0: 	int found, i;
sl@0: 	found = 0;
sl@0: 	for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
sl@0: 	    for (entryPtr = globalTablePtr->buckets[i];
sl@0: 		    entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
sl@0: 		if ((entryPtr == globalPtr)
sl@0: 		        && (entryPtr->objPtr == objPtr)) {
sl@0: 		    found = 1;
sl@0: 		}
sl@0: 	    }
sl@0: 	}
sl@0: 	if (!found) {
sl@0: 	    panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
sl@0: 	            (length>60? 60 : length), bytes);
sl@0: 	}
sl@0:     }
sl@0: #endif /*TCL_COMPILE_DEBUG*/
sl@0: #ifdef TCL_COMPILE_STATS   
sl@0:     iPtr->stats.numLiteralsCreated++;
sl@0:     iPtr->stats.totalLitStringBytes   += (double) (length + 1);
sl@0:     iPtr->stats.currentLitStringBytes += (double) (length + 1);
sl@0:     iPtr->stats.literalCount[TclLog2(length)]++;
sl@0: #endif /*TCL_COMPILE_STATS*/
sl@0:     return objIndex;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclLookupLiteralEntry --
sl@0:  *
sl@0:  *	Finds the LiteralEntry that corresponds to a literal Tcl object
sl@0:  *      holding a literal.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Returns the matching LiteralEntry if found, otherwise NULL.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: LiteralEntry *
sl@0: TclLookupLiteralEntry(interp, objPtr)
sl@0:     Tcl_Interp *interp;		/* Interpreter for which objPtr was created
sl@0:                                  * to hold a literal. */
sl@0:     register Tcl_Obj *objPtr;	/* Points to a Tcl object holding a
sl@0:                                  * literal that was previously created by a
sl@0:                                  * call to TclRegisterLiteral. */
sl@0: {
sl@0:     Interp *iPtr = (Interp *) interp;
sl@0:     LiteralTable *globalTablePtr = &(iPtr->literalTable);
sl@0:     register LiteralEntry *entryPtr;
sl@0:     char *bytes;
sl@0:     int length, globalHash;
sl@0: 
sl@0:     bytes = Tcl_GetStringFromObj(objPtr, &length);
sl@0:     globalHash = (HashString(bytes, length) & globalTablePtr->mask);
sl@0:     for (entryPtr = globalTablePtr->buckets[globalHash];
sl@0:             entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
sl@0:         if (entryPtr->objPtr == objPtr) {
sl@0:             return entryPtr;
sl@0:         }
sl@0:     }
sl@0:     return NULL;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclHideLiteral --
sl@0:  *
sl@0:  *	Remove a literal entry from the literal hash tables, leaving it in
sl@0:  *	the literal array so existing references continue to function.
sl@0:  *	This makes it possible to turn a shared literal into a private
sl@0:  *	literal that cannot be shared.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Removes the literal from the local hash table and decrements the
sl@0:  *	global hash entry's reference count.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclHideLiteral(interp, envPtr, index)
sl@0:     Tcl_Interp *interp;		 /* Interpreter for which objPtr was created
sl@0:                                   * to hold a literal. */
sl@0:     register CompileEnv *envPtr; /* Points to CompileEnv whose literal array
sl@0: 				  * contains the entry being hidden. */
sl@0:     int index;			 /* The index of the entry in the literal
sl@0: 				  * array. */
sl@0: {
sl@0:     LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
sl@0:     LiteralTable *localTablePtr = &(envPtr->localLitTable);
sl@0:     int localHash, length;
sl@0:     char *bytes;
sl@0:     Tcl_Obj *newObjPtr;
sl@0: 
sl@0:     lPtr = &(envPtr->literalArrayPtr[index]);
sl@0: 
sl@0:     /*
sl@0:      * To avoid unwanted sharing we need to copy the object and remove it from
sl@0:      * the local and global literal tables.  It still has a slot in the literal
sl@0:      * array so it can be referred to by byte codes, but it will not be matched
sl@0:      * by literal searches.
sl@0:      */
sl@0: 
sl@0:     newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
sl@0:     Tcl_IncrRefCount(newObjPtr);
sl@0:     TclReleaseLiteral(interp, lPtr->objPtr);
sl@0:     lPtr->objPtr = newObjPtr;
sl@0: 
sl@0:     bytes = Tcl_GetStringFromObj(newObjPtr, &length);
sl@0:     localHash = (HashString(bytes, length) & localTablePtr->mask);
sl@0:     nextPtrPtr = &localTablePtr->buckets[localHash];
sl@0: 
sl@0:     for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) {
sl@0: 	if (entryPtr == lPtr) {
sl@0: 	    *nextPtrPtr = lPtr->nextPtr;
sl@0: 	    lPtr->nextPtr = NULL;
sl@0: 	    localTablePtr->numEntries--;
sl@0: 	    break;
sl@0: 	}
sl@0: 	nextPtrPtr = &entryPtr->nextPtr;
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclAddLiteralObj --
sl@0:  *
sl@0:  *	Add a single literal object to the literal array.  This
sl@0:  *	function does not add the literal to the local or global
sl@0:  *	literal tables.  The caller is expected to add the entry
sl@0:  *	to whatever tables are appropriate.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The index in the CompileEnv's literal array that references the
sl@0:  *	literal.  Stores the pointer to the new literal entry in the
sl@0:  *	location referenced by the localPtrPtr argument.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Expands the literal array if necessary.  Increments the refcount
sl@0:  *	on the literal object.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclAddLiteralObj(envPtr, objPtr, litPtrPtr)
sl@0:     register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
sl@0: 				  * array the object is to be inserted. */
sl@0:     Tcl_Obj *objPtr;		 /* The object to insert into the array. */
sl@0:     LiteralEntry **litPtrPtr;	 /* The location where the pointer to the
sl@0: 				  * new literal entry should be stored.
sl@0: 				  * May be NULL. */
sl@0: {
sl@0:     register LiteralEntry *lPtr;
sl@0:     int objIndex;
sl@0: 
sl@0:     if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
sl@0: 	ExpandLocalLiteralArray(envPtr);
sl@0:     }
sl@0:     objIndex = envPtr->literalArrayNext;
sl@0:     envPtr->literalArrayNext++;
sl@0: 
sl@0:     lPtr = &(envPtr->literalArrayPtr[objIndex]);
sl@0:     lPtr->objPtr = objPtr;
sl@0:     Tcl_IncrRefCount(objPtr);
sl@0:     lPtr->refCount = -1;	/* i.e., unused */
sl@0:     lPtr->nextPtr = NULL;
sl@0: 
sl@0:     if (litPtrPtr) {
sl@0: 	*litPtrPtr = lPtr;
sl@0:     }
sl@0: 
sl@0:     return objIndex;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * AddLocalLiteralEntry --
sl@0:  *
sl@0:  *	Insert a new literal into a CompileEnv's local literal array.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The index in the CompileEnv's literal array that references the
sl@0:  *	literal.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Increments the ref count of the global LiteralEntry since the
sl@0:  *	CompileEnv now refers to the literal. Expands the literal array
sl@0:  *	if necessary. May rebuild the hash bucket array of the CompileEnv's
sl@0:  *	literal array if it becomes too large.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: AddLocalLiteralEntry(envPtr, globalPtr, localHash)
sl@0:     register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
sl@0: 				  * array the object is to be inserted. */
sl@0:     LiteralEntry *globalPtr;	 /* Points to the global LiteralEntry for
sl@0: 				  * the literal to add to the CompileEnv. */
sl@0:     int localHash;		 /* Hash value for the literal's string. */
sl@0: {
sl@0:     register LiteralTable *localTablePtr = &(envPtr->localLitTable);
sl@0:     LiteralEntry *localPtr;
sl@0:     int objIndex;
sl@0:     
sl@0:     objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);
sl@0: 
sl@0:     /*
sl@0:      * Add the literal to the local table.
sl@0:      */
sl@0: 
sl@0:     localPtr->nextPtr = localTablePtr->buckets[localHash];
sl@0:     localTablePtr->buckets[localHash] = localPtr;
sl@0:     localTablePtr->numEntries++;
sl@0: 
sl@0:     globalPtr->refCount++;
sl@0: 
sl@0:     /*
sl@0:      * If the CompileEnv's local literal table has exceeded a decent size,
sl@0:      * rebuild it with more buckets.
sl@0:      */
sl@0: 
sl@0:     if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
sl@0: 	RebuildLiteralTable(localTablePtr);
sl@0:     }
sl@0: 
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0:     TclVerifyLocalLiteralTable(envPtr);
sl@0:     {
sl@0: 	char *bytes;
sl@0: 	int length, found, i;
sl@0: 	found = 0;
sl@0: 	for (i = 0;  i < localTablePtr->numBuckets;  i++) {
sl@0: 	    for (localPtr = localTablePtr->buckets[i];
sl@0: 		    localPtr != NULL;  localPtr = localPtr->nextPtr) {
sl@0: 		if (localPtr->objPtr == globalPtr->objPtr) {
sl@0: 		    found = 1;
sl@0: 		}
sl@0: 	    }
sl@0: 	}
sl@0: 	if (!found) {
sl@0: 	    bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
sl@0: 	    panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
sl@0: 	            (length>60? 60 : length), bytes);
sl@0: 	}
sl@0:     }
sl@0: #endif /*TCL_COMPILE_DEBUG*/
sl@0:     return objIndex;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * ExpandLocalLiteralArray --
sl@0:  *
sl@0:  *	Procedure that uses malloc to allocate more storage for a
sl@0:  *	CompileEnv's local literal array.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	The literal array in *envPtr is reallocated to a new array of
sl@0:  *	double the size, and if envPtr->mallocedLiteralArray is non-zero
sl@0:  *	the old array is freed. Entries are copied from the old array
sl@0:  *	to the new one. The local literal table is updated to refer to
sl@0:  *	the new entries.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: ExpandLocalLiteralArray(envPtr)
sl@0:     register CompileEnv *envPtr; /* Points to the CompileEnv whose object
sl@0: 				  * array must be enlarged. */
sl@0: {
sl@0:     /*
sl@0:      * The current allocated local literal entries are stored between
sl@0:      * elements 0 and (envPtr->literalArrayNext - 1) [inclusive].
sl@0:      */
sl@0: 
sl@0:     LiteralTable *localTablePtr = &(envPtr->localLitTable);
sl@0:     int currElems = envPtr->literalArrayNext;
sl@0:     size_t currBytes = (currElems * sizeof(LiteralEntry));
sl@0:     register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
sl@0:     register LiteralEntry *newArrayPtr =
sl@0: 	    (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
sl@0:     int i;
sl@0:     
sl@0:     /*
sl@0:      * Copy from the old literal array to the new, then update the local
sl@0:      * literal table's bucket array.
sl@0:      */
sl@0: 
sl@0:     memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
sl@0:     for (i = 0;  i < currElems;  i++) {
sl@0: 	if (currArrayPtr[i].nextPtr == NULL) {
sl@0: 	    newArrayPtr[i].nextPtr = NULL;
sl@0: 	} else {
sl@0: 	    newArrayPtr[i].nextPtr = newArrayPtr
sl@0: 		    + (currArrayPtr[i].nextPtr - currArrayPtr);
sl@0: 	}
sl@0:     }
sl@0:     for (i = 0;  i < localTablePtr->numBuckets;  i++) {
sl@0: 	if (localTablePtr->buckets[i] != NULL) {
sl@0: 	    localTablePtr->buckets[i] = newArrayPtr
sl@0: 	            + (localTablePtr->buckets[i] - currArrayPtr);
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Free the old literal array if needed, and mark the new literal
sl@0:      * array as malloced.
sl@0:      */
sl@0:     
sl@0:     if (envPtr->mallocedLiteralArray) {
sl@0: 	ckfree((char *) currArrayPtr);
sl@0:     }
sl@0:     envPtr->literalArrayPtr = newArrayPtr;
sl@0:     envPtr->literalArrayEnd = (2 * currElems);
sl@0:     envPtr->mallocedLiteralArray = 1;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclReleaseLiteral --
sl@0:  *
sl@0:  *	This procedure releases a reference to one of the shared Tcl objects
sl@0:  *	that hold literals. It is called to release the literals referenced
sl@0:  *	by a ByteCode that is being destroyed, and it is also called by
sl@0:  *	TclDeleteLiteralTable.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	The reference count for the global LiteralTable entry that 
sl@0:  *	corresponds to the literal is decremented. If no other reference
sl@0:  *	to a global literal object remains, it is freed.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclReleaseLiteral(interp, objPtr)
sl@0:     Tcl_Interp *interp;		/* Interpreter for which objPtr was created
sl@0: 				 * to hold a literal. */
sl@0:     register Tcl_Obj *objPtr;	/* Points to a literal object that was
sl@0: 				 * previously created by a call to
sl@0: 				 * TclRegisterLiteral. */
sl@0: {
sl@0:     Interp *iPtr = (Interp *) interp;
sl@0:     LiteralTable *globalTablePtr = &(iPtr->literalTable);
sl@0:     register LiteralEntry *entryPtr, *prevPtr;
sl@0:     ByteCode* codePtr;
sl@0:     char *bytes;
sl@0:     int length, index;
sl@0: 
sl@0:     bytes = Tcl_GetStringFromObj(objPtr, &length);
sl@0:     index = (HashString(bytes, length) & globalTablePtr->mask);
sl@0: 
sl@0:     /*
sl@0:      * Check to see if the object is in the global literal table and 
sl@0:      * remove this reference.  The object may not be in the table if
sl@0:      * it is a hidden local literal.
sl@0:      */
sl@0: 
sl@0:     for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
sl@0: 	    entryPtr != NULL;
sl@0: 	    prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
sl@0: 	if (entryPtr->objPtr == objPtr) {
sl@0: 	    entryPtr->refCount--;
sl@0: 
sl@0: 	    /*
sl@0: 	     * If the literal is no longer being used by any ByteCode,
sl@0: 	     * delete the entry then remove the reference corresponding 
sl@0: 	     * to the global literal table entry (decrement the ref count 
sl@0: 	     * of the object).
sl@0: 	     */
sl@0: 		
sl@0: 	    if (entryPtr->refCount == 0) {
sl@0: 		if (prevPtr == NULL) {
sl@0: 		    globalTablePtr->buckets[index] = entryPtr->nextPtr;
sl@0: 		} else {
sl@0: 		    prevPtr->nextPtr = entryPtr->nextPtr;
sl@0: 		}
sl@0: 		ckfree((char *) entryPtr);
sl@0: 		globalTablePtr->numEntries--;
sl@0: 
sl@0: 		TclDecrRefCount(objPtr);
sl@0: 
sl@0: 		/*
sl@0: 		 * Check if the LiteralEntry is only being kept alive by 
sl@0: 		 * a circular reference from a ByteCode stored as its 
sl@0: 		 * internal rep. In that case, set the ByteCode object array 
sl@0: 		 * entry NULL to signal to TclCleanupByteCode to not try to 
sl@0: 		 * release this about to be freed literal again.
sl@0: 		 */
sl@0: 	    
sl@0: 		if (objPtr->typePtr == &tclByteCodeType) {
sl@0: 		    codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
sl@0: 		    if ((codePtr->numLitObjects == 1)
sl@0: 		            && (codePtr->objArrayPtr[0] == objPtr)) {			
sl@0: 			codePtr->objArrayPtr[0] = NULL;
sl@0: 		    }
sl@0: 		}
sl@0: 
sl@0: #ifdef TCL_COMPILE_STATS
sl@0: 		iPtr->stats.currentLitStringBytes -= (double) (length + 1);
sl@0: #endif /*TCL_COMPILE_STATS*/
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0:     }
sl@0:     
sl@0:     /*
sl@0:      * Remove the reference corresponding to the local literal table
sl@0:      * entry.
sl@0:      */
sl@0: 
sl@0:     Tcl_DecrRefCount(objPtr);
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * HashString --
sl@0:  *
sl@0:  *	Compute a one-word summary of a text string, which can be
sl@0:  *	used to generate a hash index.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The return value is a one-word summary of the information in
sl@0:  *	string.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static unsigned int
sl@0: HashString(bytes, length)
sl@0:     register CONST char *bytes; /* String for which to compute hash
sl@0: 				 * value. */
sl@0:     int length;			/* Number of bytes in the string. */
sl@0: {
sl@0:     register unsigned int result;
sl@0:     register int i;
sl@0: 
sl@0:     /*
sl@0:      * I tried a zillion different hash functions and asked many other
sl@0:      * people for advice.  Many people had their own favorite functions,
sl@0:      * all different, but no-one had much idea why they were good ones.
sl@0:      * I chose the one below (multiply by 9 and add new character)
sl@0:      * because of the following reasons:
sl@0:      *
sl@0:      * 1. Multiplying by 10 is perfect for keys that are decimal strings,
sl@0:      *    and multiplying by 9 is just about as good.
sl@0:      * 2. Times-9 is (shift-left-3) plus (old).  This means that each
sl@0:      *    character's bits hang around in the low-order bits of the
sl@0:      *    hash value for ever, plus they spread fairly rapidly up to
sl@0:      *    the high-order bits to fill out the hash value.  This seems
sl@0:      *    works well both for decimal and non-decimal strings.
sl@0:      */
sl@0: 
sl@0:     result = 0;
sl@0:     for (i = 0;  i < length;  i++) {
sl@0: 	result += (result<<3) + *bytes++;
sl@0:     }
sl@0:     return result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * RebuildLiteralTable --
sl@0:  *
sl@0:  *	This procedure is invoked when the ratio of entries to hash buckets
sl@0:  *	becomes too large in a local or global literal table. It allocates
sl@0:  *	a larger bucket array and moves the entries into the new buckets.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Memory gets reallocated and entries get rehashed into new buckets.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: RebuildLiteralTable(tablePtr)
sl@0:     register LiteralTable *tablePtr; /* Local or global table to enlarge. */
sl@0: {
sl@0:     LiteralEntry **oldBuckets;
sl@0:     register LiteralEntry **oldChainPtr, **newChainPtr;
sl@0:     register LiteralEntry *entryPtr;
sl@0:     LiteralEntry **bucketPtr;
sl@0:     char *bytes;
sl@0:     int oldSize, count, index, length;
sl@0: 
sl@0:     oldSize = tablePtr->numBuckets;
sl@0:     oldBuckets = tablePtr->buckets;
sl@0: 
sl@0:     /*
sl@0:      * Allocate and initialize the new bucket array, and set up
sl@0:      * hashing constants for new array size.
sl@0:      */
sl@0: 
sl@0:     tablePtr->numBuckets *= 4;
sl@0:     tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
sl@0: 	    (tablePtr->numBuckets * sizeof(LiteralEntry *)));
sl@0:     for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
sl@0: 	    count > 0;
sl@0: 	    count--, newChainPtr++) {
sl@0: 	*newChainPtr = NULL;
sl@0:     }
sl@0:     tablePtr->rebuildSize *= 4;
sl@0:     tablePtr->mask = (tablePtr->mask << 2) + 3;
sl@0: 
sl@0:     /*
sl@0:      * Rehash all of the existing entries into the new bucket array.
sl@0:      */
sl@0: 
sl@0:     for (oldChainPtr = oldBuckets;
sl@0: 	    oldSize > 0;
sl@0: 	    oldSize--, oldChainPtr++) {
sl@0: 	for (entryPtr = *oldChainPtr;  entryPtr != NULL;
sl@0: 	        entryPtr = *oldChainPtr) {
sl@0: 	    bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
sl@0: 	    index = (HashString(bytes, length) & tablePtr->mask);
sl@0: 	    
sl@0: 	    *oldChainPtr = entryPtr->nextPtr;
sl@0: 	    bucketPtr = &(tablePtr->buckets[index]);
sl@0: 	    entryPtr->nextPtr = *bucketPtr;
sl@0: 	    *bucketPtr = entryPtr;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Free up the old bucket array, if it was dynamically allocated.
sl@0:      */
sl@0: 
sl@0:     if (oldBuckets != tablePtr->staticBuckets) {
sl@0: 	ckfree((char *) oldBuckets);
sl@0:     }
sl@0: }
sl@0: 
sl@0: #ifdef TCL_COMPILE_STATS
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclLiteralStats --
sl@0:  *
sl@0:  *	Return statistics describing the layout of the hash table
sl@0:  *	in its hash buckets.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The return value is a malloc-ed string containing information
sl@0:  *	about tablePtr.  It is the caller's responsibility to free
sl@0:  *	this string.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: char *
sl@0: TclLiteralStats(tablePtr)
sl@0:     LiteralTable *tablePtr;	/* Table for which to produce stats. */
sl@0: {
sl@0: #define NUM_COUNTERS 10
sl@0:     int count[NUM_COUNTERS], overflow, i, j;
sl@0:     double average, tmp;
sl@0:     register LiteralEntry *entryPtr;
sl@0:     char *result, *p;
sl@0: 
sl@0:     /*
sl@0:      * Compute a histogram of bucket usage. For each bucket chain i,
sl@0:      * j is the number of entries in the chain.
sl@0:      */
sl@0: 
sl@0:     for (i = 0;  i < NUM_COUNTERS;  i++) {
sl@0: 	count[i] = 0;
sl@0:     }
sl@0:     overflow = 0;
sl@0:     average = 0.0;
sl@0:     for (i = 0;  i < tablePtr->numBuckets;  i++) {
sl@0: 	j = 0;
sl@0: 	for (entryPtr = tablePtr->buckets[i];  entryPtr != NULL;
sl@0: 	        entryPtr = entryPtr->nextPtr) {
sl@0: 	    j++;
sl@0: 	}
sl@0: 	if (j < NUM_COUNTERS) {
sl@0: 	    count[j]++;
sl@0: 	} else {
sl@0: 	    overflow++;
sl@0: 	}
sl@0: 	tmp = j;
sl@0: 	average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Print out the histogram and a few other pieces of information.
sl@0:      */
sl@0: 
sl@0:     result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
sl@0:     sprintf(result, "%d entries in table, %d buckets\n",
sl@0: 	    tablePtr->numEntries, tablePtr->numBuckets);
sl@0:     p = result + strlen(result);
sl@0:     for (i = 0; i < NUM_COUNTERS; i++) {
sl@0: 	sprintf(p, "number of buckets with %d entries: %d\n",
sl@0: 		i, count[i]);
sl@0: 	p += strlen(p);
sl@0:     }
sl@0:     sprintf(p, "number of buckets with %d or more entries: %d\n",
sl@0: 	    NUM_COUNTERS, overflow);
sl@0:     p += strlen(p);
sl@0:     sprintf(p, "average search distance for entry: %.1f", average);
sl@0:     return result;
sl@0: }
sl@0: #endif /*TCL_COMPILE_STATS*/
sl@0: 
sl@0: #ifdef TCL_COMPILE_DEBUG
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclVerifyLocalLiteralTable --
sl@0:  *
sl@0:  *	Check a CompileEnv's local literal table for consistency.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Panics if problems are found.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclVerifyLocalLiteralTable(envPtr)
sl@0:     CompileEnv *envPtr;		/* Points to CompileEnv whose literal
sl@0: 				 * table is to be validated. */
sl@0: {
sl@0:     register LiteralTable *localTablePtr = &(envPtr->localLitTable);
sl@0:     register LiteralEntry *localPtr;
sl@0:     char *bytes;
sl@0:     register int i;
sl@0:     int length, count;
sl@0: 
sl@0:     count = 0;
sl@0:     for (i = 0;  i < localTablePtr->numBuckets;  i++) {
sl@0: 	for (localPtr = localTablePtr->buckets[i];
sl@0: 	        localPtr != NULL;  localPtr = localPtr->nextPtr) {
sl@0: 	    count++;
sl@0: 	    if (localPtr->refCount != -1) {
sl@0: 		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
sl@0: 		panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
sl@0: 		        (length>60? 60 : length), bytes,
sl@0: 		        localPtr->refCount);
sl@0: 	    }
sl@0: 	    if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
sl@0: 		    localPtr->objPtr) == NULL) {
sl@0: 		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
sl@0: 		panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
sl@0: 		         (length>60? 60 : length), bytes);
sl@0: 	    }
sl@0: 	    if (localPtr->objPtr->bytes == NULL) {
sl@0: 		panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     if (count != localTablePtr->numEntries) {
sl@0: 	panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
sl@0: 	      count, localTablePtr->numEntries);
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclVerifyGlobalLiteralTable --
sl@0:  *
sl@0:  *	Check an interpreter's global literal table literal for consistency.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Panics if problems are found.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: TclVerifyGlobalLiteralTable(iPtr)
sl@0:     Interp *iPtr;		/* Points to interpreter whose global
sl@0: 				 * literal table is to be validated. */
sl@0: {
sl@0:     register LiteralTable *globalTablePtr = &(iPtr->literalTable);
sl@0:     register LiteralEntry *globalPtr;
sl@0:     char *bytes;
sl@0:     register int i;
sl@0:     int length, count;
sl@0: 
sl@0:     count = 0;
sl@0:     for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
sl@0: 	for (globalPtr = globalTablePtr->buckets[i];
sl@0: 	        globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
sl@0: 	    count++;
sl@0: 	    if (globalPtr->refCount < 1) {
sl@0: 		bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
sl@0: 		panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
sl@0: 		        (length>60? 60 : length), bytes,
sl@0: 		        globalPtr->refCount);
sl@0: 	    }
sl@0: 	    if (globalPtr->objPtr->bytes == NULL) {
sl@0: 		panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     if (count != globalTablePtr->numEntries) {
sl@0: 	panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
sl@0: 	      count, globalTablePtr->numEntries);
sl@0:     }
sl@0: }
sl@0: #endif /*TCL_COMPILE_DEBUG*/