tclliteral.c

tcl是工具命令语言

/* 
 * 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.11 2001/10/11 22:28:01 msofer 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.
 *
 *----------------------------------------------------------------------