tcl.git - Tcl is a high-level, general-purpose, interpreted, dynamic programming language. It was designed with the goal of being very simple but powerful.

	Commit message (Expand)	Author	Age	Files	Lines
*	Tidying up, adding names to log entries, etc.	dkf	2007-10-11	1	-99/+96

*	Split off changelog entries for 2004	dkf	2005-10-18	1	-0/+4622

/* * tclCompile.c -- * * This file contains procedures that compile Tcl commands or parts * of commands (like quoted strings or nested sub-commands) into a * sequence of instructions ("bytecodes"). * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCompile.c,v 1.43.2.15 2009/07/14 16:31:49 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Table of all AuxData types. */ static Tcl_HashTable auxDataTypeTable; static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) /* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ #ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; #endif /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. * The names "op1" and "op4" refer to an instruction's one or four byte * first operand. Similarly, "stktop" and "stknext" refer to the topmost * and next to topmost stack elements. * * Note that the load, store, and incr instructions do not distinguish local * from global variables; the bytecode interpreter at runtime uses the * existence of a procedure call frame to distinguish these. */ InstructionDesc tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types Stack top, next */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ {"push1", 2, +1, 1, {OPERAND_UINT1}}, /* Push object at ByteCode objArray[op1] */ {"push4", 5, +1, 1, {OPERAND_UINT4}}, /* Push object at ByteCode objArray[op4] */ {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ {"evalStk", 1, 0, 0, {OPERAND_NONE}}, /* Evaluate command in stktop using Tcl_EvalObj. */ {"exprStk", 1, 0, 0, {OPERAND_NONE}}, /* Execute expression in stktop using Tcl_ExprStringObj. */ {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}}, /* Load scalar variable at index op1 <= 255 in call frame */ {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}}, /* Load scalar variable at index op1 >= 256 in call frame */ {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, /* Load scalar variable; scalar's name is stktop */ {"loadArray1", 2, 0, 1, {OPERAND_UINT1}}, /* Load array element; array at slot op1<=255, element is stktop */ {"loadArray4", 5, 0, 1, {OPERAND_UINT4}}, /* Load array element; array at slot op1 > 255, element is stktop */ {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, /* Load array element; element is stktop, array name is stknext */ {"loadStk", 1, 0, 0, {OPERAND_NONE}}, /* Load general variable; unparsed variable name is stktop */ {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* Store scalar variable at op1<=255 in frame; value is stktop */ {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}}, /* Store scalar variable at op1 > 255 in frame; value is stktop */ {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Store scalar; value is stktop, scalar name is stknext */ {"storeArray1", 2, -1, 1, {OPERAND_UINT1}}, /* Store array element; array at op1<=255, value is top then elem */ {"storeArray4", 5, -1, 1, {OPERAND_UINT4}}, /* Store array element; array at op1>=256, value is top then elem */ {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Store array element; value is stktop, then elem, array names */ {"storeStk", 1, -1, 0, {OPERAND_NONE}}, /* Store general variable; value is stktop, then unparsed name */ {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr scalar; incr amount is stktop, scalar's name is stknext */ {"incrArray1", 2, -1, 1, {OPERAND_UINT1}}, /* Incr array elem; arr at slot op1<=255, amount is top then elem */ {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Incr array element; amount is top then elem then array names */ {"incrStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr general variable; amount is stktop then unparsed var name */ {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}}, /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr scalar; scalar name is stktop; incr amount is op1 */ {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}}, /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, /* Incr array element; elem is top then array name, amount is op1 */ {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ {"jump1", 2, 0, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) */ {"jump4", 5, 0, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) */ {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"lor", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ {"land", 1, -1, 0, {OPERAND_NONE}}, /* Logical and: push (stknext && stktop) */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ {"bitxor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise xor push (stknext ^ stktop) */ {"bitand", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise and: push (stknext & stktop) */ {"eq", 1, -1, 0, {OPERAND_NONE}}, /* Equal: push (stknext == stktop) */ {"neq", 1, -1, 0, {OPERAND_NONE}}, /* Not equal: push (stknext != stktop) */ {"lt", 1, -1, 0, {OPERAND_NONE}}, /* Less: push (stknext < stktop) */ {"gt", 1, -1, 0, {OPERAND_NONE}}, /* Greater: push (stknext || stktop) */ {"le", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ {"ge", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ {"lshift", 1, -1, 0, {OPERAND_NONE}}, /* Left shift: push (stknext << stktop) */ {"rshift", 1, -1, 0, {OPERAND_NONE}}, /* Right shift: push (stknext >> stktop) */ {"add", 1, -1, 0, {OPERAND_NONE}}, /* Add: push (stknext + stktop) */ {"sub", 1, -1, 0, {OPERAND_NONE}}, /* Sub: push (stkext - stktop) */ {"mult", 1, -1, 0, {OPERAND_NONE}}, /* Multiply: push (stknext * stktop) */ {"div", 1, -1, 0, {OPERAND_NONE}}, /* Divide: push (stknext / stktop) */ {"mod", 1, -1, 0, {OPERAND_NONE}}, /* Mod: push (stknext % stktop) */ {"uplus", 1, 0, 0, {OPERAND_NONE}}, /* Unary plus: push +stktop */ {"uminus", 1, 0, 0, {OPERAND_NONE}}, /* Unary minus: push -stktop */ {"bitnot", 1, 0, 0, {OPERAND_NONE}}, /* Bitwise not: push ~stktop */ {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, /* Call builtin math function with index op1; any args are on stk */ {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ {"break", 1, 0, 0, {OPERAND_NONE}}, /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ {"continue", 1, 0, 0, {OPERAND_NONE}}, /* Skip to next iteration of closest enclosing loop; if none, * return TCL_CONTINUE code. */ {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. */ {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, /* "Step" or begin next iteration of foreach loop. Push 0 if to * terminate loop, else push 1. */ {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, /* Record start of catch with the operand's exception index. * Push the current stack depth onto a special catch stack. */ {"endCatch", 1, 0, 0, {OPERAND_NONE}}, /* End of last catch. Pop the bytecode interpreter's catch stack. */ {"pushResult", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's object result onto the stack. */ {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as * a new object onto the stack. */ {"streq", 1, -1, 0, {OPERAND_NONE}}, /* Str Equal: push (stknext eq stktop) */ {"strneq", 1, -1, 0, {OPERAND_NONE}}, /* Str !Equal: push (stknext neq stktop) */ {"strcmp", 1, -1, 0, {OPERAND_NONE}}, /* Str Compare: push (stknext cmp stktop) */ {"strlen", 1, 0, 0, {OPERAND_NONE}}, /* Str Length: push (strlen stktop) */ {"strindex", 1, -1, 0, {OPERAND_NONE}}, /* Str Index: push (strindex stknext stktop) */ {"strmatch", 2, -1, 1, {OPERAND_INT1}}, /* Str Match: push (strmatch stknext stktop) opnd == nocase */ {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* List: push (stk1 stk2 ... stktop) */ {"listindex", 1, -1, 0, {OPERAND_NONE}}, /* List Index: push (listindex stknext stktop) */ {"listlength", 1, 0, 0, {OPERAND_NONE}}, /* List Len: push (listlength stktop) */ {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* Append scalar variable at op1<=255 in frame; value is stktop */ {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}}, /* Append scalar variable at op1 > 255 in frame; value is stktop */ {"appendArray1", 2, -1, 1, {OPERAND_UINT1}}, /* Append array element; array at op1<=255, value is top then elem */ {"appendArray4", 5, -1, 1, {OPERAND_UINT4}}, /* Append array element; array at op1>=256, value is top then elem */ {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Append array element; value is stktop, then elem, array names */ {"appendStk", 1, -1, 0, {OPERAND_NONE}}, /* Append general variable; value is stktop, then unparsed name */ {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* Lappend scalar variable at op1<=255 in frame; value is stktop */ {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}}, /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}}, /* Lappend array element; array at op1<=255, value is top then elem */ {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}}, /* Lappend array element; array at op1>=256, value is top then elem */ {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Lappend array element; value is stktop, then elem, array names */ {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, /* Lappend general variable; value is stktop, then unparsed name */ {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Lindex with generalized args, operand is number of stacked objs * used: (operand-1) entries from stktop are the indices; then list * to process. */ {"over", 5, +1, 1, {OPERAND_UINT4}}, /* Duplicate the arg-th element from top of stack (TOS=0) */ {"lsetList", 1, -2, 0, {OPERAND_NONE}}, /* Four-arg version of 'lset'. stktop is old value; next is * new element value, next is the index list; pushes new value */ {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Three- or >=5-arg version of 'lset', operand is number of * stacked objs: stktop is old value, next is new element value, next * come (operand-2) indices; pushes the new value. */ {0} }; /* * Prototypes for procedures defined later in this file: */ static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr)); static void EnterCmdExtentData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes)); static void EnterCmdStartData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset)); static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, CONST char *command, int length)); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats _ANSI_ARGS_(( ByteCode *codePtr)); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); #ifdef TCL_TIP280 /* TIP #280 : Helper for building the per-word line information of all * compiled commands */ static void EnterCmdWordData _ANSI_ARGS_(( ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr, CONST char* cmd, int len, int numWords, int line, int** lines)); #endif /* * The structure below defines the bytecode Tcl object type by * means of procedures that can be invoked by generic object code. */ Tcl_ObjType tclByteCodeType = { "bytecode", /* name */ FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetByteCodeFromAny /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * TclSetByteCodeFromAny -- * * Part of the bytecode Tcl object type implementation. Attempts to * generate an byte code internal form for the Tcl object "objPtr" by * compiling its string representation. This function also takes * a hook procedure that will be invoked to perform any needed post * processing on the compilation results before generating byte * codes. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * Frees the old internal representation. If no error occurs, then the * compiled code is stored as "objPtr"s bytecode representation. * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable * used to trace compilations. * *---------------------------------------------------------------------- */ int TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) Tcl_Interp *interp; /* The interpreter for which the code is * being compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ CompileHookProc *hookProc; /* Procedure to invoke after compilation. */ ClientData clientData; /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure * allocated in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; int length, nested, result; char *string; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { if (Tcl_LinkVar(interp, "tcl_traceCompile", (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); } traceInitialized = 1; } #endif if (iPtr->evalFlags & TCL_BRACKET_TERM) { nested = 1; } else { nested = 0; } string = Tcl_GetStringFromObj(objPtr, &length); #ifndef TCL_TIP280 TclInitCompileEnv(interp, &compEnv, string, length); #else /* * TIP #280. Pick up the CmdFrame in which the BC compiler was invoked * and use to initialize the tracking in the compiler. This information * was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc * (tclProc.c). */ TclInitCompileEnv(interp, &compEnv, string, length, iPtr->invokeCmdFramePtr, iPtr->invokeWord); #endif result = TclCompileScript(interp, string, length, nested, &compEnv); if (result == TCL_OK) { /* * Successful compilation. Add a "done" instruction at the end. */ compEnv.numSrcBytes = iPtr->termOffset; TclEmitOpcode(INST_DONE, &compEnv); /* * Invoke the compilation hook procedure if one exists. */ if (hookProc) { result = (*hookProc)(interp, &compEnv, clientData); } /* * Change the object into a ByteCode object. Ownership of the literal * objects and aux data items is given to the ByteCode object. */ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); } #endif /* TCL_COMPILE_DEBUG */ } if (result != TCL_OK) { /* * Compilation errors. */ entryPtr = compEnv.literalArrayPtr; for (i = 0; i < compEnv.literalArrayNext; i++) { TclReleaseLiteral(interp, entryPtr->objPtr); entryPtr++; } #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable(iPtr); #endif /*TCL_COMPILE_DEBUG*/ auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { if (auxDataPtr->type->freeProc != NULL) { auxDataPtr->type->freeProc(auxDataPtr->clientData); } auxDataPtr++; } } /* * Free storage allocated during compilation. */ if (localTablePtr->buckets != localTablePtr->staticBuckets) { ckfree((char *) localTablePtr->buckets); } TclFreeCompileEnv(&compEnv); return result; } /* *----------------------------------------------------------------------- * * SetByteCodeFromAny -- * * Part of the bytecode Tcl object type implementation. Attempts to * generate an byte code internal form for the Tcl object "objPtr" by * compiling its string representation. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * Frees the old internal representation. If no error occurs, then the * compiled code is stored as "objPtr"s bytecode representation. * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable * used to trace compilations. * *---------------------------------------------------------------------- */ static int SetByteCodeFromAny(interp, objPtr) Tcl_Interp *interp; /* The interpreter for which the code is * being compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { return TclSetByteCodeFromAny(interp, objPtr, (CompileHookProc *) NULL, (ClientData) NULL); } /* *---------------------------------------------------------------------- * * DupByteCodeInternalRep -- * * Part of the bytecode Tcl object type implementation. However, it * does not copy the internal representation of a bytecode Tcl_Obj, but * instead leaves the new object untyped (with a NULL type pointer). * Code will be compiled for the new object only if necessary. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void DupByteCodeInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { return; } /* *---------------------------------------------------------------------- * * FreeByteCodeInternalRep -- * * Part of the bytecode Tcl object type implementation. Frees the * storage associated with a bytecode object's internal representation * unless its code is actively being executed. * * Results: * None. * * Side effects: * The bytecode object's internal rep is marked invalid and its * code gets freed unless the code is actively being executed. * In that case the cleanup is delayed until the last execution * of the code completes. * *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep(objPtr) register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ { register ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; } /* *---------------------------------------------------------------------- * * TclCleanupByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's * reference count becomes zero. * * Results: * None. * * Side effects: * Frees objPtr's bytecode internal representation and sets its type * and objPtr->internalRep.otherValuePtr NULL. Also releases its * literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ void TclCleanupByteCode(codePtr) register ByteCode *codePtr; /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; #ifdef TCL_TIP280 Interp* iPtr = (Interp*) interp; #endif int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; register Tcl_Obj **objArrayPtr; register AuxData *auxDataPtr; int i; #ifdef TCL_COMPILE_STATS if (interp != NULL) { ByteCodeStats *statsPtr; Tcl_Time destroyTime; int lifetimeSec, lifetimeMicroSec, log2; statsPtr = &((Interp *) interp)->stats; statsPtr->numByteCodesFreed++; statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; statsPtr->currentLitBytes -= (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); statsPtr->currentExceptBytes -= (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); statsPtr->currentAuxBytes -= (double) (codePtr->numAuxDataItems * sizeof(AuxData)); statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; Tcl_GetTime(&destroyTime); lifetimeSec = destroyTime.sec - codePtr->createTime.sec; if (lifetimeSec > 2000) { /* avoid overflow */ lifetimeSec = 2000; } lifetimeMicroSec = 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); log2 = TclLog2(lifetimeMicroSec); if (log2 > 31) { log2 = 31; } statsPtr->lifetimeCount[log2]++; } #endif /* TCL_COMPILE_STATS */ /* * A single heap object holds the ByteCode structure and its code, * object, command location, and auxiliary data arrays. This means we * only need to 1) decrement the ref counts of the LiteralEntry's in * its literal array, 2) call the free procs for the auxiliary data * items, and 3) free the ByteCode structure's heap object. * * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, * like those generated from tbcload) is special, as they doesn't * make use of the global literal table. They instead maintain * private references to their literals which must be decremented. */ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { register Tcl_Obj *objPtr; objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { objPtr = *objArrayPtr; if (objPtr) { Tcl_DecrRefCount(objPtr); } objArrayPtr++; } codePtr->numLitObjects = 0; } else if (interp != NULL) { /* * If the interp has already been freed, then Tcl will have already * forcefully released all the literals used by ByteCodes compiled * with respect to that interp. */ objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { /* * TclReleaseLiteral sets a ByteCode's object array entry NULL to * indicate that it has already freed the literal. */ if (*objArrayPtr != NULL) { TclReleaseLiteral(interp, *objArrayPtr); } objArrayPtr++; } } auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { if (auxDataPtr->type->freeProc != NULL) { (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); } auxDataPtr++; } #ifdef TCL_TIP280 /* * TIP #280. Release the location data associated with this byte code * structure, if any. NOTE: The interp we belong to may be gone already, * and the data with it. * * See also tclBasic.c, DeleteInterpProc */ if (iPtr) { Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); if (hePtr) { ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); int i; if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount (eclPtr->path); } for (i=0; i < eclPtr->nuloc; i++) { ckfree ((char*) eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { ckfree ((char*) eclPtr->loc); } Tcl_DeleteHashTable (&eclPtr->litInfo); ckfree ((char*) eclPtr); Tcl_DeleteHashEntry (hePtr); } } #endif TclHandleRelease(codePtr->interpHandle); ckfree((char *) codePtr); } /* *---------------------------------------------------------------------- * * TclInitCompileEnv -- * * Initializes a CompileEnv compilation environment structure for the * compilation of a string in an interpreter. * * Results: * None. * * Side effects: * The CompileEnv structure is initialized. * *---------------------------------------------------------------------- */ void #ifndef TCL_TIP280 TclInitCompileEnv(interp, envPtr, string, numBytes) #else TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word) #endif Tcl_Interp *interp; /* The interpreter for which a CompileEnv * structure is initialized. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure to * initialize. */ char *string; /* The source string to be compiled. */ int numBytes; /* Number of bytes in source string. */ #ifdef TCL_TIP280 CONST CmdFrame* invoker; /* Location context invoking the bcc */ int word; /* Index of the word in that context * getting compiled */ #endif { Interp *iPtr = (Interp *) interp; envPtr->iPtr = iPtr; envPtr->source = string; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = NULL; envPtr->numCommands = 0; envPtr->exceptDepth = 0; envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; envPtr->currStackDepth = 0; TclInitLiteralTable(&(envPtr->localLitTable)); envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); envPtr->mallocedCodeArray = 0; envPtr->literalArrayPtr = envPtr->staticLiteralSpace; envPtr->literalArrayNext = 0; envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; #ifdef TCL_TIP280 /* * TIP #280: Set up the extended command location information, based on * the context invoking the byte code compiler. This structure is used to * keep the per-word line information for all compiled commands. * * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the * non-compiling evaluator */ envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc)); envPtr->extCmdMapPtr->loc = NULL; envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); if (invoker == NULL || (invoker->type == TCL_LOCATION_EVAL_LIST)) { /* * Initialize the compiler for relative counting in case of a * dynamic context. */ envPtr->line = 1; envPtr->extCmdMapPtr->type = (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); } else { /* Initialize the compiler using the context, making counting absolute * to that context. Note that the context can be byte code * execution. In that case we have to fill out the missing pieces * (line, path, ...). Which may make change the type as well. */ CmdFrame ctx = *invoker; int pc = 0; if (invoker->type == TCL_LOCATION_BC) { /* Note: Type BC => ctx.data.eval.path is not used. * ctx.data.tebc.codePtr is used instead. */ TclGetSrcInfoForPc (&ctx); pc = 1; } if ((ctx.nline <= word) || (ctx.line[word] < 0)) { /* Word is not a literal, relative counting */ envPtr->line = 1; envPtr->extCmdMapPtr->type = (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { /* * The reference made by 'TclGetSrcInfoForPc' is dead. */ Tcl_DecrRefCount(ctx.data.eval.path); } } else { envPtr->line = ctx.line [word]; envPtr->extCmdMapPtr->type = ctx.type; envPtr->extCmdMapPtr->path = ctx.data.eval.path; if (ctx.type == TCL_LOCATION_SOURCE) { if (pc) { /* The reference 'TclGetSrcInfoForPc' made is transfered */ ctx.data.eval.path = NULL; } else { /* We have a new reference here */ Tcl_IncrRefCount (ctx.data.eval.path); } } } /* ctx going out of scope */ } #endif envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; envPtr->mallocedAuxDataArray = 0; } /* *---------------------------------------------------------------------- * * TclFreeCompileEnv -- * * Free the storage allocated in a CompileEnv compilation environment * structure. * * Results: * None. * * Side effects: * Allocated storage in the CompileEnv structure is freed. Note that * its local literal table is not deleted and its literal objects are * not released. In addition, storage referenced by its auxiliary data * items is not freed. This is done so that, when compilation is * successful, "ownership" of these objects and aux data items is * handed over to the corresponding ByteCode structure. * *---------------------------------------------------------------------- */ void TclFreeCompileEnv(envPtr) register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ { if (envPtr->mallocedCodeArray) { ckfree((char *) envPtr->codeStart); } if (envPtr->mallocedLiteralArray) { ckfree((char *) envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { ckfree((char *) envPtr->exceptArrayPtr); } if (envPtr->mallocedCmdMap) { ckfree((char *) envPtr->cmdMapPtr); } if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } } #ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * * TclWordKnownAtCompileTime -- * * Test whether the value of a token is completely known at compile time. * * Results: * Returns true if the tokenPtr argument points to a word value that is * completely known at compile time. Generally, values that are known at * compile time can be compiled to their values, while values that cannot * be known until substitution at runtime must be compiled to bytecode * instructions that perform that substitution. For several commands, * whether or not arguments are known at compile time determine whether * it is worthwhile to compile at all. * * Side effects: * None. * * TIP #280 *---------------------------------------------------------------------- */ int TclWordKnownAtCompileTime (tokenPtr) Tcl_Token* tokenPtr; { int i; Tcl_Token* sub; if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;}; if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;}; /* Check the sub tokens of the word. It is a literal if we find * only BS and TEXT tokens */ for (i=0, sub = tokenPtr + 1; i < tokenPtr->numComponents; i++, sub ++) { if (sub->type == TCL_TOKEN_TEXT) continue; if (sub->type == TCL_TOKEN_BS) continue; return 0; } return 1; } #endif /* *---------------------------------------------------------------------- * * TclCompileScript -- * * Compile a Tcl script in a string. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * interp->termOffset is set to the offset of the character in the * script just after the last one successfully processed; this will be * the offset of the ']' if (flags & TCL_BRACKET_TERM). * * Side effects: * Adds instructions to envPtr to evaluate the script at runtime. * *---------------------------------------------------------------------- */ int TclCompileScript(interp, script, numBytes, nested, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. * Also serves as context for finding and * compiling commands. May not be NULL. */ CONST char *script; /* The source script to compile. */ int numBytes; /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ int nested; /* Non-zero means this is a nested command: * close bracket ']' should be considered a * command terminator. If zero, close * bracket has no special meaning. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Interp *iPtr = (Interp *) interp; Tcl_Parse parse; int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized * to avoid compiler warning. */ int startCodeOffset = -1; /* Offset of first byte of current command's * code. Init. to avoid compiler warning. */ unsigned char *entryCodeNext = envPtr->codeNext; CONST char *p, *next; Namespace *cmdNsPtr; Command *cmdPtr; Tcl_Token *tokenPtr; int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex; int commandLength, objIndex, code; Tcl_DString ds; #ifdef TCL_TIP280 /* TIP #280 */ ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; int* wlines; int wlineat, cmdLine; #endif Tcl_DStringInit(&ds); if (numBytes < 0) { numBytes = strlen(script); } Tcl_ResetResult(interp); isFirstCmd = 1; /* * Each iteration through the following loop compiles the next * command from the script. */ p = script; bytesLeft = numBytes; gotParse = 0; #ifdef TCL_TIP280 cmdLine = envPtr->line; #endif do { if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { code = TCL_ERROR; goto error; } gotParse = 1; if (nested) { /* * This is an unusual situation where the caller has passed us * a non-zero value for "nested". How unusual? Well, this * procedure, TclCompileScript, is internal to Tcl, so all * callers should be within Tcl itself. All but one of those * callers explicitly pass in (nested = 0). The exceptional * caller is TclSetByteCodeFromAny, which will pass in * (nested = 1) if and only if the flag TCL_BRACKET_TERM * is set in the evalFlags field of interp. * * It appears that the TCL_BRACKET_TERM flag is only ever set * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx * which clears the flag before passing the interp along. * So, I don't think this procedure, TclCompileScript, is * **ever** called with (nested != 0). * (The testsuite indeed doesn't exercise this code. MS) * * This means that the branches in this procedure that are * only active when (nested != 0) are probably never exercised. * This means that any bugs in them go unnoticed, and any bug * fixes in them have a semi-theoretical nature. * * All that said, the spec for this procedure says it should * handle the (nested != 0) case, so here's an attempt to fix * bugs (Tcl Bug 681841) in that case. Just in case some * callers eventually come along and expect it to work... */ if (parse.term == (script + numBytes)) { /* * The (nested != 0) case is meant to indicate that the * caller found an open bracket ([) and asked us to * parse and compile Tcl commands up to the matching * close bracket (]). We have to detect and handle * the case where the close bracket is missing. */ Tcl_SetObjResult(interp, Tcl_NewStringObj("missing close-bracket", -1)); code = TCL_ERROR; goto error; } } if (parse.numWords > 0) { /* * If not the first command, pop the previous command's result * and, if we're compiling a top level command, update the last * command's code size to account for the pop instruction. */ if (!isFirstCmd) { TclEmitOpcode(INST_POP, envPtr); if (!nested) { envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - startCodeOffset; } } /* * Determine the actual length of the command. */ commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* * The command terminator character (such as ; or ]) is * the last character in the parsed command. Reduce the * length by one so that the trace message doesn't include * the terminator character. */ commandLength -= 1; } #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. */ if ((tclTraceCompile >= 1) && !nested && (envPtr->procPtr == NULL)) { fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parse.commandStart, TclMin(commandLength, 55)); fprintf(stdout, "\n"); } #endif /* * Each iteration of the following loop compiles one word * from the command. */ envPtr->numCommands++; currCmdIndex = (envPtr->numCommands - 1); if (!nested) { lastTopLevelCmdIndex = currCmdIndex; } startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, (parse.commandStart - envPtr->source), startCodeOffset); #ifdef TCL_TIP280 /* TIP #280. Scan the words and compute the extended location * information. The map first contain full per-word line * information for use by the compiler. This is later replaced by * a reduced form which signals non-literal words, stored in * 'wlines'. */ TclAdvanceLines (&cmdLine, p, parse.commandStart); EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source), parse.tokenPtr, parse.commandStart, parse.commandSize, parse.numWords, cmdLine, &wlines); wlineat = eclPtr->nuloc - 1; #endif for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { #ifdef TCL_TIP280 envPtr->line = eclPtr->loc [wlineat].line [wordIdx]; #endif if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* * If this is the first word and the command has a * compile procedure, let it compile the command. */ if (wordIdx == 0) { if (envPtr->procPtr != NULL) { cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; } else { cmdNsPtr = NULL; /* use current NS */ } /* * We copy the string before trying to find the command * by name. We used to modify the string in place, but * this is not safe because the name resolution * handlers could have side effects that rely on the * unmodified string. */ Tcl_DStringSetLength(&ds, 0); Tcl_DStringAppend(&ds, tokenPtr[1].start, tokenPtr[1].size); cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { int savedNumCmds = envPtr->numCommands; unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart; code = (*(cmdPtr->compileProc))(interp, &parse, envPtr); if (code == TCL_OK) { goto finishCommand; } else if (code == TCL_OUT_LINE_COMPILE) { /* * Restore numCommands and codeNext to their correct * values, removing any commands compiled before * TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055] */ envPtr->numCommands = savedNumCmds; envPtr->codeNext = envPtr->codeStart + savedCodeNext; } else { /* an error */ /* * There was a compilation error, the last * command did not get compiled into (*envPtr). * Decrement the number of commands * claimed to be in (*envPtr). */ envPtr->numCommands--; goto log; } } /* * No compile procedure so push the word. If the * command was found, push a CmdName object to * reduce runtime lookups. */ objIndex = TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); if (cmdPtr != NULL) { TclSetCmdNameObj(interp, envPtr->literalArrayPtr[objIndex].objPtr, cmdPtr); } } else { /* Simple argument word of a command. We reach this if * and only if the command word was not compiled for * whatever reason. Register the literal's location * for use by uplevel, etc. commands, should they * encounter it unmodified. We care only if the we are * in a context which already allows absolute * counting. */ objIndex = TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } TclEmitPush(objIndex, envPtr); } else { /* * The word is not a simple string of characters. */ code = TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); if (code != TCL_OK) { goto log; } } } /* * Emit an invoke instruction for the command. We skip this * if a compile procedure was found for the command. */ if (wordIdx > 0) { #ifdef TCL_TIP280 /* * Save PC -> command map for the TclArgumentBC* functions. */ int isnew; Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, (char*) (envPtr->codeNext - envPtr->codeStart), &isnew); Tcl_SetHashValue(hePtr, (char*) wlineat); #endif if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); } } /* * Update the compilation environment structure and record the * offsets of the source and code for the command. */ finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; #ifdef TCL_TIP280 /* TIP #280: Free full form of per-word line data and insert * the reduced form now */ ckfree ((char*) eclPtr->loc [wlineat].line); eclPtr->loc [wlineat].line = wlines; #endif } /* end if parse.numWords > 0 */ /* * Advance to the next command in the script. */ next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; #ifdef TCL_TIP280 /* TIP #280 : Track lines in the just compiled command */ TclAdvanceLines (&cmdLine, parse.commandStart, p); #endif Tcl_FreeParse(&parse); gotParse = 0; if (nested && (*parse.term == ']')) { /* * We get here in the special case where TCL_BRACKET_TERM was * set in the interpreter and the latest parsed command was * terminated by the matching close-bracket we were looking for. * Stop compilation. */ break; } } while (bytesLeft > 0); /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. */ if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); } if (nested) { /* * When (nested != 0) back up 1 character to have * iPtr->termOffset indicate the offset to the matching * close-bracket. */ iPtr->termOffset = (p - 1) - script; } else { iPtr->termOffset = (p - script); } Tcl_DStringFree(&ds); return TCL_OK; error: /* * Generate various pieces of error information, such as the line * number where the error occurred and information to add to the * errorInfo variable. Then free resources that had been allocated * to the command. */ commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* * The terminator character (such as ; or ]) of the command where * the error occurred is the last character in the parsed command. * Reduce the length by one so that the error message doesn't * include the terminator character. */ commandLength -= 1; } log: LogCompilationInfo(interp, script, parse.commandStart, commandLength); if (gotParse) { Tcl_FreeParse(&parse); } iPtr->termOffset = (p - script); Tcl_DStringFree(&ds); return code; } /* *---------------------------------------------------------------------- * * TclCompileTokens -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens * that make up a word) this procedure emits instructions to evaluate * the tokens and concatenate their values to form a single result * value on the interpreter's runtime evaluation stack. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: * Instructions are added to envPtr to push and evaluate the tokens * at runtime. * *---------------------------------------------------------------------- */ int TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens * to compile. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; CONST char *name, *p; int numObjsToConcat, nameBytes, localVarName, localVar; int length, i, code; unsigned char *entryCodeNext = envPtr->codeNext; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); break; case TCL_TOKEN_BS: length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); Tcl_DStringAppend(&textBuffer, buffer, length); break; case TCL_TOKEN_COMMAND: /* * Push any accumulated chars appearing before the command. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } code = TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, /*nested*/ 0, envPtr); if (code != TCL_OK) { goto error; } numObjsToConcat++; break; case TCL_TOKEN_VARIABLE: /* * Push any accumulated chars appearing before the $<var>. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } /* * Determine how the variable name should be handled: if it contains * any namespace qualifiers it is not a local variable (localVarName=-1); * if it looks like an array element and the token has a single component, * it should not be created here [Bug 569438] (localVarName=0); otherwise, * the local variable can safely be created (localVarName=1). */ name = tokenPtr[1].start; nameBytes = tokenPtr[1].size; localVarName = -1; if (envPtr->procPtr != NULL) { localVarName = 1; for (i = 0, p = name; i < nameBytes; i++, p++) { if ((*p == ':') && (i < (nameBytes-1)) && (*(p+1) == ':')) { localVarName = -1; break; } else if ((*p == '(') && (tokenPtr->numComponents == 1) && (*(name + nameBytes - 1) == ')')) { localVarName = 0; break; } } } /* * Either push the variable's name, or find its index in * the array of local variables in a procedure frame. */ localVar = -1; if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, localVarName, /*flags*/ 0, envPtr->procPtr); } if (localVar < 0) { TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), envPtr); } /* * Emit instructions to load the variable. */ if (tokenPtr->numComponents == 1) { if (localVar < 0) { TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); } else { TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); } } else { code = TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); if (code != TCL_OK) { char errorBuffer[150]; sprintf(errorBuffer, "\n (parsing index for array \"%.*s\")", ((nameBytes > 100)? 100 : nameBytes), name); Tcl_AddObjErrorInfo(interp, errorBuffer, -1); goto error; } if (localVar < 0) { TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); } else { TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); } } numObjsToConcat++; count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; default: panic("Unexpected token type in TclCompileTokens"); } } /* * Push any accumulated characters appearing at the end. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; } /* * If necessary, concatenate the parts of the word. */ while (numObjsToConcat > 255) { TclEmitInstInt1(INST_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); } /* * If the tokens yielded no instructions, push an empty string. */ if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); } Tcl_DStringFree(&textBuffer); return TCL_OK; error: Tcl_DStringFree(&textBuffer); return code; } /* *---------------------------------------------------------------------- * * TclCompileCmdWord -- * * Given an array of parse tokens for a word containing one or more Tcl * commands, emit inline instructions to execute them. This procedure * differs from TclCompileTokens in that a simple word such as a loop * body enclosed in braces is not just pushed as a string, but is * itself parsed into tokens and compiled. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: * Instructions are added to envPtr to execute the tokens at runtime. * *---------------------------------------------------------------------- */ int TclCompileCmdWord(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens * for a command word to compile inline. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { int code; /* * Handle the common case: if there is a single text token, compile it * into an inline sequence of instructions. */ if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, /*nested*/ 0, envPtr); return code; } /* * Multiple tokens or the single token involves substitutions. Emit * instructions to invoke the eval command procedure at runtime on the * result of evaluating the tokens. */ code = TclCompileTokens(interp, tokenPtr, count, envPtr); if (code != TCL_OK) { return code; } TclEmitOpcode(INST_EVAL_STK, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileExprWords -- * * Given an array of parse tokens representing one or more words that * contain a Tcl expression, emit inline instructions to execute the * expression. This procedure differs from TclCompileExpr in that it * supports Tcl's two-level substitution semantics for expressions that * appear as command words. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: * Instructions are added to envPtr to execute the expression. * *---------------------------------------------------------------------- */ int TclCompileExprWords(interp, tokenPtr, numWords, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Points to first in an array of word * tokens tokens for the expression to * compile inline. */ int numWords; /* Number of word tokens starting at * tokenPtr. Must be at least 1. Each word * token contains one or more subtokens. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; int numBytes, i, code; CONST char *script; code = TCL_OK; /* * If the expression is a single word that doesn't require * substitutions, just compile its string into inline instructions. */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { script = tokenPtr[1].start; numBytes = tokenPtr[1].size; code = TclCompileExpr(interp, script, numBytes, envPtr); return code; } /* * Emit code to call the expr command proc at runtime. Concatenate the * (already substituted once) expr tokens with a space between each. */ wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); if (code != TCL_OK) { break; } if (i < (numWords - 1)) { TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), envPtr); } wordPtr += (wordPtr->numComponents + 1); } if (code == TCL_OK) { int concatItems = 2*numWords - 1; while (concatItems > 255) { TclEmitInstInt1(INST_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } return code; } /* *---------------------------------------------------------------------- * * TclInitByteCodeObj -- * * Create a ByteCode structure and initialize it from a CompileEnv * compilation environment structure. The ByteCode structure is * smaller and contains just that information needed to execute * the bytecode instructions resulting from compiling a Tcl script. * The resulting structure is placed in the specified object. * * Results: * A newly constructed ByteCode object is stored in the internal * representation of the objPtr. * * Side effects: * A single heap object is allocated to hold the new ByteCode structure * and its code, object, command location, and aux data arrays. Note * that "ownership" (i.e., the pointers to) the Tcl objects and aux * data items will be handed over to the new ByteCode structure from * the CompileEnv structure. * *---------------------------------------------------------------------- */ void TclInitByteCodeObj(objPtr, envPtr) Tcl_Obj *objPtr; /* Points object that should be * initialized, and whose string rep * contains the source code. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { register ByteCode *codePtr; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; size_t auxDataArrayBytes, structureSize; register unsigned char *p; #ifdef TCL_COMPILE_DEBUG unsigned char *nextPtr; #endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; int i; #ifdef TCL_TIP280 int new; #endif Interp *iPtr; iPtr = envPtr->iPtr; codeBytes = (envPtr->codeNext - envPtr->codeStart); objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* * Compute the total number of bytes needed for this bytecode. */ structureSize = sizeof(ByteCode); structureSize += TCL_ALIGN(codeBytes); /* align object array */ structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ structureSize += auxDataArrayBytes; structureSize += cmdLocBytes; if (envPtr->iPtr->varFramePtr != NULL) { namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { namespacePtr = envPtr->iPtr->globalNsPtr; } p = (unsigned char *) ckalloc((size_t) structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; codePtr->refCount = 1; codePtr->flags = 0; codePtr->source = envPtr->source; codePtr->procPtr = envPtr->procPtr; codePtr->numCommands = envPtr->numCommands; codePtr->numSrcBytes = envPtr->numSrcBytes; codePtr->numCodeBytes = codeBytes; codePtr->numLitObjects = numLitObjects; codePtr->numExceptRanges = envPtr->exceptArrayNext; codePtr->numAuxDataItems = envPtr->auxDataArrayNext; codePtr->numCmdLocBytes = cmdLocBytes; codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; p += sizeof(ByteCode); codePtr->codeStart = p; memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } p += auxDataArrayBytes; #ifndef TCL_COMPILE_DEBUG EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); if (((size_t)(nextPtr - p)) != cmdLocBytes) { panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); } #endif /* * Record various compilation-related statistics about the new ByteCode * structure. Don't include overhead for statistics-related fields. */ #ifdef TCL_COMPILE_STATS codePtr->structureSize = structureSize - (sizeof(size_t) + sizeof(Tcl_Time)); Tcl_GetTime(&(codePtr->createTime)); RecordByteCodeStats(codePtr); #endif /* TCL_COMPILE_STATS */ /* * Free the old internal rep then convert the object to a * bytecode object by making its internal rep point to the just * compiled ByteCode. */ if ((objPtr->typePtr != NULL) && (objPtr->typePtr->freeIntRepProc != NULL)) { (*objPtr->typePtr->freeIntRepProc)(objPtr); } objPtr->internalRep.otherValuePtr = (VOID *) codePtr; objPtr->typePtr = &tclByteCodeType; #ifdef TCL_TIP280 /* TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; #endif } /* *---------------------------------------------------------------------- * * LogCompilationInfo -- * * This procedure is invoked after an error occurs during compilation. * It adds information to the "errorInfo" variable to describe the * command that was being compiled when the error occurred. * * Results: * None. * * Side effects: * Information about the command is added to errorInfo and the * line number stored internally in the interpreter is set. If this * is the first call to this procedure or Tcl_AddObjErrorInfo since * an error occurred, then old information in errorInfo is * deleted. * *---------------------------------------------------------------------- */ static void LogCompilationInfo(interp, script, command, length) Tcl_Interp *interp; /* Interpreter in which to log the * information. */ CONST char *script; /* First character in script containing * command (must be <= command). */ CONST char *command; /* First character in command that * generated the error. */ int length; /* Number of bytes in command (-1 means * use all bytes up to first null byte). */ { char buffer[200]; register CONST char *p; char *ellipsis = ""; Interp *iPtr = (Interp *) interp; if (iPtr->flags & ERR_ALREADY_LOGGED) { /* * Someone else has already logged error information for this * command; we shouldn't add anything more. */ return; } /* * Compute the line number where the error occurred. */ iPtr->errorLine = 1; for (p = script; p != command; p++) { if (*p == '\n') { iPtr->errorLine++; } } /* * Create an error message to add to errorInfo, including up to a * maximum number of characters of the command. */ if (length < 0) { length = strlen(command); } if (length > 150) { length = 150; ellipsis = "..."; } while ( (command[length] & 0xC0) == 0x80 ) { /* * Back up truncation point so that we don't truncate in the * middle of a multi-byte character (in UTF-8) */ length--; ellipsis = "..."; } sprintf(buffer, "\n while compiling\n\"%.*s%s\"", length, command, ellipsis); Tcl_AddObjErrorInfo(interp, buffer, -1); } /* *---------------------------------------------------------------------- * * TclFindCompiledLocal -- * * This procedure is called at compile time to look up and optionally * allocate an entry ("slot") for a variable in a procedure's array of * local variables. If the variable's name is NULL, a new temporary * variable is always created. (Such temporary variables can only be * referenced using their slot index.) * * Results: * If create is 0 and the name is non-NULL, then if the variable is * found, the index of its entry in the procedure's array of local * variables is returned; otherwise -1 is returned. If name is NULL, * the index of a new temporary variable is returned. Finally, if * create is 1 and name is non-NULL, the index of a new entry is * returned. * * Side effects: * Creates and registers a new local variable if create is 1 and * the variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ int TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) register CONST char *name; /* Points to first character of the name of * a scalar or array variable. If NULL, a * temporary var should be created. */ int nameBytes; /* Number of bytes in the name. */ int create; /* If 1, allocate a local frame entry for * the variable if it is new. */ int flags; /* Flag bits for the compiled local if * created. Only VAR_SCALAR, VAR_ARRAY, and * VAR_LINK make sense. */ register Proc *procPtr; /* Points to structure describing procedure * containing the variable reference. */ { register CompiledLocal *localPtr; int localVar = -1; register int i; /* * If not creating a temporary, does a local variable of the specified * name already exist? */ if (name != NULL) { int localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && (strncmp(name, localName, (unsigned) nameBytes) == 0)) { return i; } } localPtr = localPtr->nextPtr; } } /* * Create a new variable if appropriate. */ if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; localPtr = (CompiledLocal *) ckalloc((unsigned) (sizeof(CompiledLocal) - sizeof(localPtr->name) + nameBytes+1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; localPtr->nameLength = nameBytes; localPtr->frameIndex = localVar; localPtr->flags = flags | VAR_UNDEFINED; if (name == NULL) { localPtr->flags |= VAR_TEMPORARY; } localPtr->defValuePtr = NULL; localPtr->resolveInfo = NULL; if (name != NULL) { memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; } return localVar; } /* *---------------------------------------------------------------------- * * TclInitCompiledLocals -- * * This routine is invoked in order to initialize the compiled * locals table for a new call frame. * * Results: * None. * * Side effects: * May invoke various name resolvers in order to determine which * variables are being referenced at runtime. * *---------------------------------------------------------------------- */ void TclInitCompiledLocals(interp, framePtr, nsPtr) Tcl_Interp *interp; /* Current interpreter. */ CallFrame *framePtr; /* Call frame to initialize. */ Namespace *nsPtr; /* Pointer to current namespace. */ { register CompiledLocal *localPtr; Interp *iPtr = (Interp*) interp; Tcl_ResolvedVarInfo *vinfo, *resVarInfo; Var *varPtr = framePtr->compiledLocals; Var *resolvedVarPtr; ResolverScheme *resPtr; int result; /* * Initialize the array of local variables stored in the call frame. * Some variables may have special resolution rules. In that case, * we call their "resolver" procs to get our hands on the variable, * and we make the compiled local a link to the real variable. */ for (localPtr = framePtr->procPtr->firstLocalPtr; localPtr != NULL; localPtr = localPtr->nextPtr) { /* * Check to see if this local is affected by namespace or * interp resolvers. The resolver to use is cached for the * next invocation of the procedure. */ if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { resPtr = iPtr->resolverPtr; if (nsPtr->compiledVarResProc) { result = (*nsPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } else { result = TCL_CONTINUE; } while ((result == TCL_CONTINUE) && resPtr) { if (resPtr->compiledVarResProc) { result = (*resPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } resPtr = resPtr->nextPtr; } if (result == TCL_OK) { localPtr->resolveInfo = vinfo; localPtr->flags |= VAR_RESOLVED; } } /* * Now invoke the resolvers to determine the exact variables that * should be used. */ resVarInfo = localPtr->resolveInfo; resolvedVarPtr = NULL; if (resVarInfo && resVarInfo->fetchProc) { resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, resVarInfo); } if (resolvedVarPtr) { varPtr->name = localPtr->name; /* will be just '\0' if temp var */ varPtr->nsPtr = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = 0; TclSetVarLink(varPtr); varPtr->value.linkPtr = resolvedVarPtr; resolvedVarPtr->refCount++; } else { varPtr->value.objPtr = NULL; varPtr->name = localPtr->name; /* will be just '\0' if temp var */ varPtr->nsPtr = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = localPtr->flags; } varPtr++; } } /* *---------------------------------------------------------------------- * * TclExpandCodeArray -- * * Procedure that uses malloc to allocate more storage for a * CompileEnv's code array. * * Results: * None. * * Side effects: * The byte code array in *envPtr is reallocated to a new array of * double the size, and if envPtr->mallocedCodeArray is non-zero the * old array is freed. Byte codes are copied from the old array to the * new one. * *---------------------------------------------------------------------- */ void TclExpandCodeArray(envArgPtr) void *envArgPtr; /* Points to the CompileEnv whose code array * must be enlarged. */ { CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array * must be enlarged. */ /* * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined * code bytes are stored between envPtr->codeStart and * (envPtr->codeNext - 1) [inclusive]. */ size_t currBytes = (envPtr->codeNext - envPtr->codeStart); size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); /* * Copy from old code array to new, free old code array if needed, and * mark new code array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); if (envPtr->mallocedCodeArray) { ckfree((char *) envPtr->codeStart); } envPtr->codeStart = newPtr; envPtr->codeNext = (newPtr + currBytes); envPtr->codeEnd = (newPtr + newBytes); envPtr->mallocedCodeArray = 1; } /* *---------------------------------------------------------------------- * * EnterCmdStartData -- * * Registers the starting source and bytecode location of a * command. This information is used at runtime to map between * instruction pc and source locations. * * Results: * None. * * Side effects: * Inserts source and code location information into the compilation * environment envPtr for the command at index cmdIndex. The * compilation environment's CmdLocation array is grown if necessary. * *---------------------------------------------------------------------- */ static void EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ int cmdIndex; /* Index of the command whose start data * is being set. */ int srcOffset; /* Offset of first char of the command. */ int codeOffset; /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { panic("EnterCmdStartData: bad command index %d\n", cmdIndex); } if (cmdIndex >= envPtr->cmdMapEnd) { /* * Expand the command location array by allocating more storage from * the heap. The currently allocated CmdLocation entries are stored * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). */ size_t currElems = envPtr->cmdMapEnd; size_t newElems = 2*currElems; size_t currBytes = currElems * sizeof(CmdLocation); size_t newBytes = newElems * sizeof(CmdLocation); CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); /* * Copy from old command location array to new, free old command * location array if needed, and mark new array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); if (envPtr->mallocedCmdMap) { ckfree((char *) envPtr->cmdMapPtr); } envPtr->cmdMapPtr = (CmdLocation *) newPtr; envPtr->cmdMapEnd = newElems; envPtr->mallocedCmdMap = 1; } if (cmdIndex > 0) { if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { panic("EnterCmdStartData: cmd map not sorted by code offset"); } } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcBytes = -1; cmdLocPtr->numCodeBytes = -1; } /* *---------------------------------------------------------------------- * * EnterCmdExtentData -- * * Registers the source and bytecode length for a command. This * information is used at runtime to map between instruction pc and * source locations. * * Results: * None. * * Side effects: * Inserts source and code length information into the compilation * environment envPtr for the command at index cmdIndex. Starting * source and bytecode information for the command must already * have been registered. * *---------------------------------------------------------------------- */ static void EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ int cmdIndex; /* Index of the command whose source and * code length data is being set. */ int numSrcBytes; /* Number of command source chars. */ int numCodeBytes; /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { panic("EnterCmdExtentData: missing start data for command %d\n", cmdIndex); } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); cmdLocPtr->numSrcBytes = numSrcBytes; cmdLocPtr->numCodeBytes = numCodeBytes; } #ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * TIP #280 * * EnterCmdWordData -- * * Registers the lines for the words of a command. This information * is used at runtime by 'info frame'. * * Results: * None. * * Side effects: * Inserts word location information into the compilation * environment envPtr for the command at index cmdIndex. The * compilation environment's ExtCmdLoc.ECL array is grown if necessary. * *---------------------------------------------------------------------- */ static void EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines) ExtCmdLoc *eclPtr; /* Points to the map environment * structure in which to enter command * location information. */ int srcOffset; /* Offset of first char of the command. */ Tcl_Token* tokenPtr; CONST char* cmd; int len; int numWords; int line; int** wlines; { ECL* ePtr; int wordIdx; CONST char* last; int wordLine; int* wwlines; if (eclPtr->nuloc >= eclPtr->nloc) { /* * Expand the ECL array by allocating more storage from the * heap. The currently allocated ECL entries are stored from * eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive). */ size_t currElems = eclPtr->nloc; size_t newElems = (currElems ? 2*currElems : 1); size_t currBytes = currElems * sizeof(ECL); size_t newBytes = newElems * sizeof(ECL); ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes); /* * Copy from old ECL array to new, free old ECL array if * needed. */ if (currBytes) { memcpy((VOID *) newPtr, (VOID *) eclPtr->loc, currBytes); } if (eclPtr->loc != NULL) { ckfree((char *) eclPtr->loc); } eclPtr->loc = (ECL *) newPtr; eclPtr->nloc = newElems; } ePtr = &eclPtr->loc [eclPtr->nuloc]; ePtr->srcOffset = srcOffset; ePtr->line = (int*) ckalloc (numWords * sizeof (int)); ePtr->nline = numWords; wwlines = (int*) ckalloc (numWords * sizeof (int)); last = cmd; wordLine = line; for (wordIdx = 0; wordIdx < numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { TclAdvanceLines (&wordLine, last, tokenPtr->start); wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr) ? wordLine : -1); ePtr->line [wordIdx] = wordLine; last = tokenPtr->start; } *wlines = wwlines; eclPtr->nuloc ++; } #endif /* *---------------------------------------------------------------------- * * TclCreateExceptRange -- * * Procedure that allocates and initializes a new ExceptionRange * structure of the specified kind in a CompileEnv. * * Results: * Returns the index for the newly created ExceptionRange. * * Side effects: * If there is not enough room in the CompileEnv's ExceptionRange * array, the array in expanded: a new array of double the size is * allocated, if envPtr->mallocedExceptArray is non-zero the old * array is freed, and ExceptionRange entries are copied from the old * array to the new one. * *---------------------------------------------------------------------- */ int TclCreateExceptRange(type, envPtr) ExceptionRangeType type; /* The kind of ExceptionRange desired. */ register CompileEnv *envPtr;/* Points to CompileEnv for which to * create a new ExceptionRange structure. */ { register ExceptionRange *rangePtr; int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { /* * Expand the ExceptionRange array. The currently allocated entries * are stored between elements 0 and (envPtr->exceptArrayNext - 1) * [inclusive]. */ size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); ExceptionRange *newPtr = (ExceptionRange *) ckalloc((unsigned) newBytes); /* * Copy from old ExceptionRange array to new, free old * ExceptionRange array if needed, and mark the new ExceptionRange * array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, currBytes); if (envPtr->mallocedExceptArray) { ckfree((char *) envPtr->exceptArrayPtr); } envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; envPtr->exceptArrayEnd = newElems; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayNext++; rangePtr = &(envPtr->exceptArrayPtr[index]); rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; rangePtr->codeOffset = -1; rangePtr->numCodeBytes = -1; rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; return index; } /* *---------------------------------------------------------------------- * * TclCreateAuxData -- * * Procedure that allocates and initializes a new AuxData structure in * a CompileEnv's array of compilation auxiliary data records. These * AuxData records hold information created during compilation by * CompileProcs and used by instructions during execution. * * Results: * Returns the index for the newly created AuxData structure. * * Side effects: * If there is not enough room in the CompileEnv's AuxData array, * the AuxData array in expanded: a new array of double the size * is allocated, if envPtr->mallocedAuxDataArray is non-zero * the old array is freed, and AuxData entries are copied from * the old array to the new one. * *---------------------------------------------------------------------- */ int TclCreateAuxData(clientData, typePtr, envPtr) ClientData clientData; /* The compilation auxiliary data to store * in the new aux data record. */ AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; /* Points to the new AuxData structure */ index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { /* * Expand the AuxData array. The currently allocated entries are * stored between elements 0 and (envPtr->auxDataArrayNext - 1) * [inclusive]. */ size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); /* * Copy from old AuxData array to new, free old AuxData array if * needed, and mark the new AuxData array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, currBytes); if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } envPtr->auxDataArrayPtr = newPtr; envPtr->auxDataArrayEnd = newElems; envPtr->mallocedAuxDataArray = 1; } envPtr->auxDataArrayNext++; auxDataPtr = &(envPtr->auxDataArrayPtr[index]); auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; return index; } /* *---------------------------------------------------------------------- * * TclInitJumpFixupArray -- * * Initializes a JumpFixupArray structure to hold some number of * jump fixup entries. * * Results: * None. * * Side effects: * The JumpFixupArray structure is initialized. * *---------------------------------------------------------------------- */ void TclInitJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; /* Points to the JumpFixupArray structure * to initialize. */ { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); fixupArrayPtr->mallocedArray = 0; } /* *---------------------------------------------------------------------- * * TclExpandJumpFixupArray -- * * Procedure that uses malloc to allocate more storage for a * jump fixup array. * * Results: * None. * * Side effects: * The jump fixup array in *fixupArrayPtr is reallocated to a new array * of double the size, and if fixupArrayPtr->mallocedArray is non-zero * the old array is freed. Jump fixup structures are copied from the * old array to the new one. * *---------------------------------------------------------------------- */ void TclExpandJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; /* Points to the JumpFixupArray structure * to enlarge. */ { /* * The currently allocated jump fixup entries are stored from fixup[0] * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. */ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); int newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); /* * Copy from the old array to new, free the old array if needed, * and mark the new array as malloced. */ memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); } fixupArrayPtr->fixup = (JumpFixup *) newPtr; fixupArrayPtr->end = newElems; fixupArrayPtr->mallocedArray = 1; } /* *---------------------------------------------------------------------- * * TclFreeJumpFixupArray -- * * Free any storage allocated in a jump fixup array structure. * * Results: * None. * * Side effects: * Allocated storage in the JumpFixupArray structure is freed. * *---------------------------------------------------------------------- */ void TclFreeJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; /* Points to the JumpFixupArray structure * to free. */ { if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); } } /* *---------------------------------------------------------------------- * * TclEmitForwardJump -- * * Procedure to emit a two-byte forward jump of kind "jumpType". Since * the jump may later have to be grown to five bytes if the jump target * is more than, say, 127 bytes away, this procedure also initializes a * JumpFixup record with information about the jump. * * Results: * None. * * Side effects: * The JumpFixup record pointed to by "jumpFixupPtr" is initialized * with information needed later if the jump is to be grown. Also, * a two byte jump of the designated type is emitted at the current * point in the bytecode stream. * *---------------------------------------------------------------------- */ void TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) CompileEnv *envPtr; /* Points to the CompileEnv structure that * holds the resulting instruction. */ TclJumpType jumpType; /* Indicates the kind of jump: if true or * false or unconditional. */ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to * initialize with information about this * forward jump. */ { /* * Initialize the JumpFixup structure: * - codeOffset is offset of first byte of jump below * - cmdIndex is index of the command after the current one * - exceptIndex is the index of the first ExceptionRange after * the current one. */ jumpFixupPtr->jumpType = jumpType; jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); jumpFixupPtr->cmdIndex = envPtr->numCommands; jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: TclEmitInstInt1(INST_JUMP1, 0, envPtr); break; case TCL_TRUE_JUMP: TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); break; default: TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); break; } } /* *---------------------------------------------------------------------- * * TclFixupForwardJump -- * * Procedure that updates a previously-emitted forward jump to jump * a specified number of bytes, "jumpDist". If necessary, the jump is * grown from two to five bytes; this is done if the jump distance is * greater than "distThreshold" (normally 127 bytes). The jump is * described by a JumpFixup record previously initialized by * TclEmitForwardJump. * * Results: * 1 if the jump was grown and subsequent instructions had to be moved; * otherwise 0. This result is returned to allow callers to update * any additional code offsets they may hold. * * Side effects: * The jump may be grown and subsequent instructions moved. If this * happens, the code offsets for any commands and any ExceptionRange * records between the jump and the current code address will be * updated to reflect the moved code. Also, the bytecode instruction * array in the CompileEnv structure may be grown and reallocated. * *---------------------------------------------------------------------- */ int TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) CompileEnv *envPtr; /* Points to the CompileEnv structure that * holds the resulting instruction. */ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that * describes the forward jump. */ int jumpDist; /* Jump distance to set in jump * instruction. */ int distThreshold; /* Maximum distance before the two byte * jump is grown to five bytes. */ { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; unsigned int numBytes; if (jumpDist <= distThreshold) { jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); break; case TCL_TRUE_JUMP: TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); break; default: TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); break; } return 0; } /* * We must grow the jump then move subsequent instructions down. * Note that if we expand the space for generated instructions, * code addresses might change; be careful about updating any of * these addresses held in variables. */ if ((envPtr->codeNext + 3) > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); numBytes = envPtr->codeNext-jumpPc-2; p = jumpPc+2; memmove(p+3, p, numBytes); envPtr->codeNext += 3; jumpDist += 3; switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); break; case TCL_TRUE_JUMP: TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); break; default: TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); break; } /* * Adjust the code offsets for any commands and any ExceptionRange * records between the jump and the current code address. */ firstCmd = jumpFixupPtr->cmdIndex; lastCmd = (envPtr->numCommands - 1); if (firstCmd < lastCmd) { for (k = firstCmd; k <= lastCmd; k++) { (envPtr->cmdMapPtr[k]).codeOffset += 3; } } firstRange = jumpFixupPtr->exceptIndex; lastRange = (envPtr->exceptArrayNext - 1); for (k = firstRange; k <= lastRange; k++) { ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); rangePtr->codeOffset += 3; switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: rangePtr->breakOffset += 3; if (rangePtr->continueOffset != -1) { rangePtr->continueOffset += 3; } break; case CATCH_EXCEPTION_RANGE: rangePtr->catchOffset += 3; break; default: panic("TclFixupForwardJump: bad ExceptionRange type %d\n", rangePtr->type); } } return 1; /* the jump was grown */ } /* *---------------------------------------------------------------------- * * TclGetInstructionTable -- * * Returns a pointer to the table describing Tcl bytecode instructions. * This procedure is defined so that clients can access the pointer from * outside the TCL DLLs. * * Results: * Returns a pointer to the global instruction table, same as the * expression (&tclInstructionTable[0]). * * Side effects: * None. * *---------------------------------------------------------------------- */ void * /* == InstructionDesc* == */ TclGetInstructionTable() { return &tclInstructionTable[0]; } /* *-------------------------------------------------------------- * * TclRegisterAuxDataType -- * * This procedure is called to register a new AuxData type * in the table of all AuxData types supported by Tcl. * * Results: * None. * * Side effects: * The type is registered in the AuxData type table. If there was already * a type with the same name as in typePtr, it is replaced with the * new type. * *-------------------------------------------------------------- */ void TclRegisterAuxDataType(typePtr) AuxDataType *typePtr; /* Information about object type; * storage must be statically * allocated (must live forever). */ { register Tcl_HashEntry *hPtr; int new; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { TclInitAuxDataTypeTable(); } /* * If there's already a type with the given name, remove it. */ hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); if (hPtr != (Tcl_HashEntry *) NULL) { Tcl_DeleteHashEntry(hPtr); } /* * Now insert the new object type. */ hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); if (new) { Tcl_SetHashValue(hPtr, typePtr); } Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * * TclGetAuxDataType -- * * This procedure looks up an Auxdata type by name. * * Results: * If an AuxData type with name matching "typeName" is found, a pointer * to its AuxDataType structure is returned; otherwise, NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ AuxDataType * TclGetAuxDataType(typeName) char *typeName; /* Name of AuxData type to look up. */ { register Tcl_HashEntry *hPtr; AuxDataType *typePtr = NULL; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { TclInitAuxDataTypeTable(); } hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; } /* *-------------------------------------------------------------- * * TclInitAuxDataTypeTable -- * * This procedure is invoked to perform once-only initialization of * the AuxData type table. It also registers the AuxData types defined in * this file. * * Results: * None. * * Side effects: * Initializes the table of defined AuxData types "auxDataTypeTable" with * builtin AuxData types defined in this file. * *-------------------------------------------------------------- */ void TclInitAuxDataTypeTable() { /* * The table mutex must already be held before this routine is invoked. */ auxDataTypeTableInitialized = 1; Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); /* * There is only one AuxData type at this time, so register it here. */ TclRegisterAuxDataType(&tclForeachInfoType); } /* *---------------------------------------------------------------------- * * TclFinalizeAuxDataTypeTable -- * * This procedure is called by Tcl_Finalize after all exit handlers * have been run to free up storage associated with the table of AuxData * types. This procedure is called by TclFinalizeExecution() which * is called by Tcl_Finalize(). * * Results: * None. * * Side effects: * Deletes all entries in the hash table of AuxData types. * *---------------------------------------------------------------------- */ void TclFinalizeAuxDataTypeTable() { Tcl_MutexLock(&tableMutex); if (auxDataTypeTableInitialized) { Tcl_DeleteHashTable(&auxDataTypeTable); auxDataTypeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * * GetCmdLocEncodingSize -- * * Computes the total number of bytes needed to encode the command * location information for some compiled code. * * Results: * The byte count needed to encode the compiled location information. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int GetCmdLocEncodingSize(envPtr) CompileEnv *envPtr; /* Points to compilation environment * structure containing the CmdLocation * structure to encode. */ { register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; int codeDelta, codeLen, srcDelta, srcLen; int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; /* The offsets in their respective byte * sequences where the next encoded offset * or length should go. */ int prevCodeOffset, prevSrcOffset, i; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; prevCodeOffset = prevSrcOffset = 0; for (i = 0; i < numCmds; i++) { codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); if (codeDelta < 0) { panic("GetCmdLocEncodingSize: bad code offset"); } else if (codeDelta <= 127) { codeDeltaNext++; } else { codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ } prevCodeOffset = mapPtr[i].codeOffset; codeLen = mapPtr[i].numCodeBytes; if (codeLen < 0) { panic("GetCmdLocEncodingSize: bad code length"); } else if (codeLen <= 127) { codeLengthNext++; } else { codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ } srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); if ((-127 <= srcDelta) && (srcDelta <= 127)) { srcDeltaNext++; } else { srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ } prevSrcOffset = mapPtr[i].srcOffset; srcLen = mapPtr[i].numSrcBytes; if (srcLen < 0) { panic("GetCmdLocEncodingSize: bad source length"); } else if (srcLen <= 127) { srcLengthNext++; } else { srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ } } return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); } /* *---------------------------------------------------------------------- * * EncodeCmdLocMap -- * * Encode the command location information for some compiled code into * a ByteCode structure. The encoded command location map is stored as * three adjacent byte sequences. * * Results: * Pointer to the first byte after the encoded command location * information. * * Side effects: * The encoded information is stored into the block of memory headed * by codePtr. Also records pointers to the start of the four byte * sequences in fields in codePtr's ByteCode header structure. * *---------------------------------------------------------------------- */ static unsigned char * EncodeCmdLocMap(envPtr, codePtr, startPtr) CompileEnv *envPtr; /* Points to compilation environment * structure containing the CmdLocation * structure to encode. */ ByteCode *codePtr; /* ByteCode in which to encode envPtr's * command location information. */ unsigned char *startPtr; /* Points to the first byte in codePtr's * memory block where the location * information is to be stored. */ { register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; register unsigned char *p = startPtr; int codeDelta, codeLen, srcDelta, srcLen, prevOffset; register int i; /* * Encode the code offset for each command as a sequence of deltas. */ codePtr->codeDeltaStart = p; prevOffset = 0; for (i = 0; i < numCmds; i++) { codeDelta = (mapPtr[i].codeOffset - prevOffset); if (codeDelta < 0) { panic("EncodeCmdLocMap: bad code offset"); } else if (codeDelta <= 127) { TclStoreInt1AtPtr(codeDelta, p); p++; } else { TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(codeDelta, p); p += 4; } prevOffset = mapPtr[i].codeOffset; } /* * Encode the code length for each command. */ codePtr->codeLengthStart = p; for (i = 0; i < numCmds; i++) { codeLen = mapPtr[i].numCodeBytes; if (codeLen < 0) { panic("EncodeCmdLocMap: bad code length"); } else if (codeLen <= 127) { TclStoreInt1AtPtr(codeLen, p); p++; } else { TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(codeLen, p); p += 4; } } /* * Encode the source offset for each command as a sequence of deltas. */ codePtr->srcDeltaStart = p; prevOffset = 0; for (i = 0; i < numCmds; i++) { srcDelta = (mapPtr[i].srcOffset - prevOffset); if ((-127 <= srcDelta) && (srcDelta <= 127)) { TclStoreInt1AtPtr(srcDelta, p); p++; } else { TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(srcDelta, p); p += 4; } prevOffset = mapPtr[i].srcOffset; } /* * Encode the source length for each command. */ codePtr->srcLengthStart = p; for (i = 0; i < numCmds; i++) { srcLen = mapPtr[i].numSrcBytes; if (srcLen < 0) { panic("EncodeCmdLocMap: bad source length"); } else if (srcLen <= 127) { TclStoreInt1AtPtr(srcLen, p); p++; } else { TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(srcLen, p); p += 4; } } return p; } #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * TclPrintByteCodeObj -- * * This procedure prints ("disassembles") the instructions of a * bytecode object to stdout. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclPrintByteCodeObj(interp, objPtr) Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ { ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; if (codePtr->refCount <= 0) { return; /* already freed */ } codeStart = codePtr->codeStart; codeLimit = (codeStart + codePtr->numCodeBytes); numCmds = codePtr->numCommands; /* * Print header lines describing the ByteCode. */ fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", (unsigned int) codePtr, codePtr->refCount, codePtr->compileEpoch, (unsigned int) iPtr, iPtr->compileEpoch); fprintf(stdout, " Source "); TclPrintSource(stdout, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS (codePtr->numSrcBytes? ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); #else 0.0); #endif #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", codePtr->structureSize, (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), codePtr->numCodeBytes, (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (codePtr->numExceptRanges * sizeof(ExceptionRange)), (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ /* * If the ByteCode is the compiled body of a Tcl procedure, print * information about that procedure. Note that we don't know the * procedure's name since ByteCode's can be shared among procedures. */ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; fprintf(stdout, " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { fprintf(stdout, " slot %d%s%s%s%s%s%s", i, ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), ((localPtr->flags & VAR_ARRAY)? ", array" : ""), ((localPtr->flags & VAR_LINK)? ", link" : ""), ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); if (TclIsVarTemporary(localPtr)) { fprintf(stdout, "\n"); } else { fprintf(stdout, ", \"%s\"\n", localPtr->name); } localPtr = localPtr->nextPtr; } } } /* * Print the ExceptionRange array. */ if (codePtr->numExceptRanges > 0) { fprintf(stdout, " Exception ranges %d, depth %d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", i, rangePtr->nestingLevel, ((rangePtr->type == LOOP_EXCEPTION_RANGE) ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: fprintf(stdout, "continue %d, break %d\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: fprintf(stdout, "catch %d\n", rangePtr->catchOffset); break; default: panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", rangePtr->type); } } } /* * If there were no commands (e.g., an expression or an empty string * was compiled), just print all instructions and return. */ if (numCmds == 0) { pc = codeStart; while (pc < codeLimit) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } return; } /* * Print table showing the code offset, source offset, and source * length for each command. These are encoded as a sequence of bytes. */ fprintf(stdout, " Commands %d:", numCmds); codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; } else { delta = TclGetInt1AtPtr(codeDeltaNext); codeDeltaNext++; } codeOffset += delta; if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; } else { codeLen = TclGetInt1AtPtr(codeLengthNext); codeLengthNext++; } if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; } else { delta = TclGetInt1AtPtr(srcDeltaNext); srcDeltaNext++; } srcOffset += delta; if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); } if (numCmds > 0) { fprintf(stdout, "\n"); } /* * Print each instruction. If the instruction corresponds to the start * of a command, print the command's source. Note that we don't need * the code length here. */ codeDeltaNext = codePtr->codeDeltaStart; srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; pc = codeStart; for (i = 0; i < numCmds; i++) { if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; } else { delta = TclGetInt1AtPtr(codeDeltaNext); codeDeltaNext++; } codeOffset += delta; if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; } else { delta = TclGetInt1AtPtr(srcDeltaNext); srcDeltaNext++; } srcOffset += delta; if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } /* * Print instructions before command i. */ while ((pc-codeStart) < codeOffset) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } fprintf(stdout, " Command %d: ", (i+1)); TclPrintSource(stdout, (codePtr->source + srcOffset), TclMin(srcLen, 55)); fprintf(stdout, "\n"); } if (pc < codeLimit) { /* * Print instructions after the last command. */ while (pc < codeLimit) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } } } #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * TclPrintInstruction -- * * This procedure prints ("disassembles") one instruction from a * bytecode object to stdout. * * Results: * Returns the length in bytes of the current instruiction. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclPrintInstruction(codePtr, pc) ByteCode* codePtr; /* Bytecode containing the instruction. */ unsigned char *pc; /* Points to first byte of instruction. */ { Proc *procPtr = codePtr->procPtr; unsigned char opCode = *pc; register InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned int pcOffset = (pc - codeStart); int opnd, i, j; fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: opnd = TclGetInt1AtPtr(pc+1+i); if ((i == 0) && ((opCode == INST_JUMP1) || (opCode == INST_JUMP_TRUE1) || (opCode == INST_JUMP_FALSE1))) { fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); } else { fprintf(stdout, "%d", opnd); } break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+1+i); if ((i == 0) && ((opCode == INST_JUMP4) || (opCode == INST_JUMP_TRUE4) || (opCode == INST_JUMP_FALSE4))) { fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); } else { fprintf(stdout, "%d", opnd); } break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+1+i); if ((i == 0) && (opCode == INST_PUSH1)) { fprintf(stdout, "%u # ", (unsigned int) opnd); TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) || (opCode == INST_LOAD_ARRAY1) || (opCode == INST_STORE_SCALAR1) || (opCode == INST_STORE_ARRAY1))) { int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; if (opnd >= localCt) { panic("TclPrintInstruction: bad local var index %u (%u locals)\n", (unsigned int) opnd, localCt); return instDesc->numBytes; } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { fprintf(stdout, "%u # temp var %u", (unsigned int) opnd, (unsigned int) opnd); } else { fprintf(stdout, "%u # var ", (unsigned int) opnd); TclPrintSource(stdout, localPtr->name, 40); } } else { fprintf(stdout, "%u ", (unsigned int) opnd); } break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+1+i); if (opCode == INST_PUSH4) { fprintf(stdout, "%u # ", opnd); TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) || (opCode == INST_LOAD_ARRAY4) || (opCode == INST_STORE_SCALAR4) || (opCode == INST_STORE_ARRAY4))) { int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; if (opnd >= localCt) { panic("TclPrintInstruction: bad local var index %u (%u locals)\n", (unsigned int) opnd, localCt); return instDesc->numBytes; } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { fprintf(stdout, "%u # temp var %u", (unsigned int) opnd, (unsigned int) opnd); } else { fprintf(stdout, "%u # var ", (unsigned int) opnd); TclPrintSource(stdout, localPtr->name, 40); } } else { fprintf(stdout, "%u ", (unsigned int) opnd); } break; case OPERAND_NONE: default: break; } } fprintf(stdout, "\n"); return instDesc->numBytes; } /* *---------------------------------------------------------------------- * * TclPrintObject -- * * This procedure prints up to a specified number of characters from * the argument Tcl object's string representation to a specified file. * * Results: * None. * * Side effects: * Outputs characters to the specified file. * *---------------------------------------------------------------------- */ void TclPrintObject(outFile, objPtr, maxChars) FILE *outFile; /* The file to print the source to. */ Tcl_Obj *objPtr; /* Points to the Tcl object whose string * representation should be printed. */ int maxChars; /* Maximum number of chars to print. */ { char *bytes; int length; bytes = Tcl_GetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } /* *---------------------------------------------------------------------- * * TclPrintSource -- * * This procedure prints up to a specified number of characters from * the argument string to a specified file. It tries to produce legible * output by adding backslashes as necessary. * * Results: * None. * * Side effects: * Outputs characters to the specified file. * *---------------------------------------------------------------------- */ void TclPrintSource(outFile, string, maxChars) FILE *outFile; /* The file to print the source to. */ CONST char *string; /* The string to print. */ int maxChars; /* Maximum number of chars to print. */ { register CONST char *p; register int i = 0; if (string == NULL) { fprintf(outFile, "\"\""); return; } fprintf(outFile, "\""); p = string; for (; (*p != '\0') && (i < maxChars); p++, i++) { switch (*p) { case '"': fprintf(outFile, "\\\""); continue; case '\f': fprintf(outFile, "\\f"); continue; case '\n': fprintf(outFile, "\\n"); continue; case '\r': fprintf(outFile, "\\r"); continue; case '\t': fprintf(outFile, "\\t"); continue; case '\v': fprintf(outFile, "\\v"); continue; default: fprintf(outFile, "%c", *p); continue; } } fprintf(outFile, "\""); } #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * * RecordByteCodeStats -- * * Accumulates various compilation-related statistics for each newly * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is * compiled with the -DTCL_COMPILE_STATS flag * * Results: * None. * * Side effects: * Accumulates aggregate code-related statistics in the interpreter's * ByteCodeStats structure. Records statistics specific to a ByteCode * in its ByteCode structure. * *---------------------------------------------------------------------- */ void RecordByteCodeStats(codePtr) ByteCode *codePtr; /* Points to ByteCode structure with info * to add to accumulated statistics. */ { Interp *iPtr = (Interp *) *codePtr->interpHandle; register ByteCodeStats *statsPtr = &(iPtr->stats); statsPtr->numCompilations++; statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; statsPtr->currentLitBytes += (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); statsPtr->currentExceptBytes += (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); statsPtr->currentAuxBytes += (double) (codePtr->numAuxDataItems * sizeof(AuxData)); statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; } #endif /* TCL_COMPILE_STATS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */